Session JinjaThreads

Theory Set_without_equal

(*  Title:      JinjaThreads/Basic/Set_without_equal.thy
    Author:     Andreas Lochbihler
*)

theory Set_without_equal
imports Main
begin

text ‹
  Adapt @{type "set"} code setup such that @{const "insert"}, 
  @{const "union"}, and @{term "set_of_pred"} do not generate
  sort constraint @{class equal}.
›

definition insert' :: "'a  'a set  'a set"
where "insert' = Set.insert"

definition union' :: "'a set  'a set  'a set"
where "union' A B = sup A B"

declare
  insert'_def [symmetric, code_unfold]
  union'_def [symmetric, code_unfold]

lemma insert'_code:
  "insert' x (set xs) = set (x # xs)"
  by (rule set_eqI) (simp add: insert'_def)

lemma union'_code:
  "union' (set xs) (set ys) = set (xs @ ys)"
  by (rule set_eqI) (simp add: union'_def fun_eq_iff)

declare
  insert'_code [code]
  union'_code [code]

text ‹Merge name spaces to avoid cyclic module dependencies›

code_identifier
  code_module Set_without_equal 
    (SML) Set and (Haskell) Set and (OCaml) Set

end

Theory Set_Monad

theory Set_Monad
imports 
  Main
  "HOL-Library.Monad_Syntax"
begin

lemma member_SUP: (* FIXME delete candidate: should be subsumed by default simpset as soon as SUP_apply is included *)
  "x  (f ` A) = (SUP BA. (λx. x  f B)) x"
  by auto

abbreviation (input) "of_pred == Predicate.set_of_pred" (* FIXME delte alias *)
abbreviation (input) "of_seq == Predicate.set_of_seq" (* FIXME delte alias *)

lemmas bind_def = Set.bind_def (* FIXME delte alias *)
lemmas bind_bind = Set.bind_bind (* FIXME delte alias *)
lemmas empty_bind = Set.empty_bind (* FIXME delte alias *)
lemmas bind_const = Set.bind_const (* FIXME delte alias *)
lemmas member_of_pred = Predicate.member_set_of_pred (* FIXME delte alias *)
lemmas member_of_seq = Predicate.member_set_of_seq (* FIXME delte alias *)

definition single :: "'a  'a set"
  where "single a = {a}"

definition undefined :: "'a set"
  where [simp]: "undefined = Collect HOL.undefined"

declare [[code abort: undefined]]

definition Undefined :: "unit  'a set"
  where "Undefined _ = Collect HOL.undefined"

declare [[code abort: Undefined]]

lemma undefined_code [code_unfold]:
  "undefined = Undefined ()"
  by (simp add: Undefined_def)

lemma bind_single [simp, code_unfold]:
  "A  single = A"
  by (simp add: bind_def single_def)

lemma single_bind [simp, code_unfold]:
  "single a  B = B a"
  by (simp add: bind_def single_def)

declare Set.empty_bind [code_unfold]

lemma member_single [simp]:
  "x  single a  x = a"
by (simp add: single_def)

lemma single_sup_simps [simp, code_unfold]:
  shows single_sup: "sup (single a) A = insert a A"
  and sup_single: "sup A (single a) = insert a A"
  by (unfold set_eq_iff) auto

lemma single_code [code]:
  "single a = set [a]"
  by (simp add: set_eq_iff)

end

Theory JT_ICF

section ‹Adapting the Isabelle Collection Framework for Jinja Threads›
theory JT_ICF
imports Collections.CollectionsV1
begin

  text ‹Hide stuff that may lead to confusions later›

  hide_const (open) Array
  hide_type (open) array

end

Theory Auxiliary

(*  Title:      JinjaThreads/Basic/Aux.thy
    Author:     Andreas Lochbihler, David von Oheimb, Tobias Nipkow

    Based on the Jinja theory Common/Aux.thy by David von Oheimb and Tobias Nipkow
*)

section ‹Auxiliary Definitions and Lemmata›

theory Auxiliary
imports
  Complex_Main
  "HOL-Library.Transitive_Closure_Table"
  "HOL-Library.Predicate_Compile_Alternative_Defs"
  "HOL-Library.Monad_Syntax"
  "HOL-Library.Infinite_Set"
  FinFun.FinFun
begin

unbundle finfun_syntax

(* FIXME move and possibly turn into a general simproc *)
lemma nat_add_max_le[simp]:
  "((n::nat) + max i j  m) = (n + i  m  n + j  m)"
 (*<*)by arith(*>*)

lemma Suc_add_max_le[simp]:
  "(Suc(n + max i j)  m) = (Suc(n + i)  m  Suc(n + j)  m)"
(*<*)by arith(*>*)

lemma less_min_eq1:
  "(a :: 'a :: order) < b  min a b = a"
by(auto simp add: min_def order_less_imp_le)

lemma less_min_eq2:
  "(a :: 'a :: order) > b  min a b = b"
by(auto simp add: min_def order_less_imp_le)

no_notation floor ("_")
notation Some ("(_)")

(*<*)
declare
 option.splits[split]
 Let_def[simp]
 subset_insertI2 [simp]
(*>*)

declare not_Cons_self [no_atp] 

lemma Option_bind_eq_None_conv:
  "x  y = None  x = None  (x'. x = Some x'  y x' = None)"
by(cases x) simp_all

lemma Option_bind_eq_Some_conv:
  "x  y = Some z  (x'. x = Some x'  y x' = Some z)"
by(cases x) simp_all

lemma map_upds_xchg_snd:
  " length xs  length ys; length xs  length zs; i. i < length xs  ys ! i = zs ! i 
   f(xs [↦] ys) = f(xs [↦] zs)"
proof(induct xs arbitrary: ys zs f)
  case Nil thus ?case by simp
next
  case (Cons x xs)
  note IH = f ys zs.  length xs  length ys; length xs  length zs; i<length xs. ys ! i = zs ! i
              f(xs [↦] ys) = f(xs [↦] zs)
  note leny = ‹length (x # xs)  length ys
  note lenz = ‹length (x # xs)  length zs
  note nth = i<length (x # xs). ys ! i = zs ! i
  from lenz obtain z zs' where zs [simp]: "zs = z # zs'" by(cases zs, auto)
  from leny obtain y ys' where ys [simp]: "ys = y # ys'" by(cases ys, auto)
  from lenz leny nth have "(f(x  y))(xs [↦] ys') = (f(x  y))(xs [↦] zs')"
    by-(rule IH, auto)
  moreover from nth have "y = z" by auto
  ultimately show ?case by(simp add: map_upds_def)
qed

subsection distinct_fst›
 
definition
  distinct_fst  :: "('a × 'b) list  bool"
where
  "distinct_fst    distinct  map fst"

lemma distinct_fst_Nil [simp]:
  "distinct_fst []"
 (*<*)
apply (unfold distinct_fst_def)
apply (simp (no_asm))
done
(*>*)

lemma distinct_fst_Cons [simp]:
  "distinct_fst ((k,x)#kxs) = (distinct_fst kxs  (y. (k,y)  set kxs))"
(*<*)
apply (unfold distinct_fst_def)
apply (auto simp:image_def)
done
(*>*)

lemma distinct_fstD: " distinct_fst xs; (x, y)  set xs; (x, z)  set xs   y = z"
by(induct xs) auto

lemma map_of_SomeI:
  " distinct_fst kxs; (k,x)  set kxs   map_of kxs k = Some x"
(*<*)by (induct kxs) (auto simp:fun_upd_apply)(*>*)

lemma rel_option_Some1:
  "rel_option R (Some x) y  (y'. y = Some y'  R x y')"
by(cases y) simp_all

lemma rel_option_Some2:
  "rel_option R x (Some y)  (x'. x = Some x'  R x' y)"
by(cases x) simp_all

subsection ‹Using @{term list_all2} for relations›

definition
  fun_of :: "('a × 'b) set  'a  'b  bool"
where
  "fun_of S  λx y. (x,y)  S"

text ‹Convenience lemmas›
(*<*)
declare fun_of_def [simp]
(*>*)
lemma rel_list_all2_Cons [iff]:
  "list_all2 (fun_of S) (x#xs) (y#ys) = 
   ((x,y)  S  list_all2 (fun_of S) xs ys)"
  (*<*)by simp(*>*)

lemma rel_list_all2_Cons1:
  "list_all2 (fun_of S) (x#xs) ys = 
  (z zs. ys = z#zs  (x,z)  S  list_all2 (fun_of S) xs zs)"
  (*<*)by (cases ys) auto(*>*)

lemma rel_list_all2_Cons2:
  "list_all2 (fun_of S) xs (y#ys) = 
  (z zs. xs = z#zs  (z,y)  S  list_all2 (fun_of S) zs ys)"
  (*<*)by (cases xs) auto(*>*)

lemma rel_list_all2_refl:
  "(x. (x,x)  S)  list_all2 (fun_of S) xs xs"
  (*<*)by (simp add: list_all2_refl)(*>*)

lemma rel_list_all2_antisym:
  " (x y. (x,y)  S; (y,x)  T  x = y); 
     list_all2 (fun_of S) xs ys; list_all2 (fun_of T) ys xs   xs = ys"
  (*<*)by (rule list_all2_antisym) auto(*>*)

lemma rel_list_all2_trans: 
  " a b c. (a,b)  R; (b,c)  S  (a,c)  T;
    list_all2 (fun_of R) as bs; list_all2 (fun_of S) bs cs 
   list_all2 (fun_of T) as cs"
  (*<*)by (rule list_all2_trans) auto(*>*)

lemma rel_list_all2_update_cong:
  " i<size xs; list_all2 (fun_of S) xs ys; (x,y)  S  
   list_all2 (fun_of S) (xs[i:=x]) (ys[i:=y])"
  (*<*)by (simp add: list_all2_update_cong)(*>*)

lemma rel_list_all2_nthD:
  " list_all2 (fun_of S) xs ys; p < size xs   (xs!p,ys!p)  S"
  (*<*)by (drule list_all2_nthD) auto(*>*)

lemma rel_list_all2I:
  " length a = length b; n. n < length a  (a!n,b!n)  S   list_all2 (fun_of S) a b"
  (*<*)by (erule list_all2_all_nthI) simp(*>*)

(*<*)declare fun_of_def [simp del](*>*)


lemma list_all2_induct[consumes 1, case_names Nil Cons]:
  assumes major: "list_all2 P xs ys"
  and Nil: "Q [] []"
  and Cons: "x xs y ys.  P x y; list_all2 P xs ys; Q xs ys   Q (x # xs) (y # ys)"
  shows "Q xs ys"
using major
by(induct xs arbitrary: ys)(auto simp add: list_all2_Cons1 Nil intro!: Cons)

lemma list_all2_split:
  assumes major: "list_all2 P xs ys"
  and split: "x y. P x y  z. Q x z  R z y"
  shows "zs. list_all2 Q xs zs  list_all2 R zs ys"
using major
by(induct rule: list_all2_induct)(auto dest: split)

lemma list_all2_refl_conv:
  "list_all2 P xs xs  (xset xs. P x x)"
unfolding list_all2_conv_all_nth Ball_def in_set_conv_nth
by auto

lemma list_all2_op_eq [simp]:
  "list_all2 (=) xs ys  xs = ys"
by(induct xs arbitrary: ys)(auto simp add: list_all2_Cons1)

lemmas filter_replicate_conv = filter_replicate

lemma length_greater_Suc_0_conv: "Suc 0 < length xs  (x x' xs'. xs = x # x' # xs')"
by(cases xs, auto simp add: neq_Nil_conv)

lemmas zip_same_conv = zip_same_conv_map

lemma nth_Cons_subtract: "0 < n  (x # xs) ! n = xs ! (n - 1)"
by(auto simp add: nth_Cons split: nat.split)

lemma f_nth_set:
  " f (xs ! n) = v; n < length xs   v  f ` set xs"
unfolding set_conv_nth by auto

lemma nth_concat_eqI:
  " n = sum_list (map length (take i xss)) + k; i < length xss; k < length (xss ! i); x = xss ! i ! k 
   concat xss ! n = x"
apply(induct xss arbitrary: n i k)
 apply simp
apply simp
apply(case_tac i)
 apply(simp add: nth_append)
apply(simp add: nth_append)
done

lemma replicate_eq_append_conv: 
  "(replicate n x = xs @ ys) = (mn. xs = replicate m x  ys = replicate (n-m) x)"
proof(induct n arbitrary: xs ys)
  case 0 thus ?case by simp
next
  case (Suc n xs ys)
  have IH: "xs ys. (replicate n x = xs @ ys) = (mn. xs = replicate m x  ys = replicate (n - m) x)" by fact
  show ?case
  proof(unfold replicate_Suc, rule iffI)
    assume a: "x # replicate n x = xs @ ys"
    show "mSuc n. xs = replicate m x  ys = replicate (Suc n - m) x"
    proof(cases xs)
      case Nil
      thus ?thesis using a
        by(auto)
    next
      case (Cons X XS)
      with a have x: "x = X" and "replicate n x = XS @ ys" by auto
      hence "mn. XS = replicate m x  ys = replicate (n - m) x"
        by -(rule IH[THEN iffD1])
      then obtain m where "m  n" and XS: "XS = replicate m x" and ys: "ys = replicate (n - m) x" by blast
      with x Cons show ?thesis
        by(fastforce)
    qed
  next
    assume "mSuc n. xs = replicate m x  ys = replicate (Suc n - m) x"
    then obtain m where m: "m  Suc n" and xs: "xs = replicate m x" and ys: "ys = replicate (Suc n - m) x" by blast
    thus "x # replicate n x = xs @ ys"
      by(simp add: replicate_add[THEN sym])
  qed
qed

lemma replicate_Suc_snoc:
  "replicate (Suc n) x = replicate n x @ [x]"
by (metis replicate_Suc replicate_append_same)

lemma map_eq_append_conv:
  "map f xs = ys @ zs  (ys' zs'. map f ys' = ys  map f zs' = zs  xs = ys' @ zs')"
apply(rule iffI)
 apply(metis append_eq_conv_conj append_take_drop_id drop_map take_map)
by(clarsimp)

lemma append_eq_map_conv:
  "ys @ zs = map f xs  (ys' zs'. map f ys' = ys  map f zs' = zs  xs = ys' @ zs')"
unfolding map_eq_append_conv[symmetric]
by auto

lemma map_eq_map_conv:
  "map f xs = map g ys  list_all2 (λx y. f x = g y) xs ys"
apply(induct xs arbitrary: ys)
apply(auto simp add: list_all2_Cons1 Cons_eq_map_conv)
done

lemma map_eq_all_nth_conv:
  "map f xs = ys  length xs = length ys  (n < length xs. f (xs ! n) = ys ! n)"
apply(induct xs arbitrary: ys)
apply(fastforce simp add: nth_Cons Suc_length_conv split: nat.splits)+
done



lemma take_eq_take_le_eq:
  " take n xs = take n ys; m  n   take m xs = take m ys"
by(metis min.absorb_iff1 take_take)

lemma take_list_update_beyond:
  "n  m  take n (xs[m := x]) = take n xs"
by(cases "n  length xs")(rule nth_take_lemma, simp_all)

lemma hd_drop_conv_nth:
  "n < length xs  hd (drop n xs) = xs ! n"
by(rule hd_drop_conv_nth) (metis list.size(3) not_less0)

lemma set_tl_subset: "set (tl xs)  set xs"
by(cases xs) auto

lemma tl_conv_drop: "tl xs = drop 1 xs"
by(cases xs) simp_all

lemma takeWhile_eq_Nil_dropWhile_eq_Nil_imp_Nil:
  " takeWhile P xs = []; dropWhile P xs = []   xs = []"
by (metis dropWhile_eq_drop drop_0 list.size(3))

lemma takeWhile_eq_Nil_conv:
  "takeWhile P xs = []  (xs = []  ¬ P (hd xs))"
by(cases xs) simp_all

lemma dropWhile_append1': "dropWhile P xs  []  dropWhile P (xs @ ys) = dropWhile P xs @ ys"
by(cases xs) auto

lemma dropWhile_append2': "dropWhile P xs = []  dropWhile P (xs @ ys) = dropWhile P ys"
by(simp)

lemma takeWhile_append1': "dropWhile P xs  []  takeWhile P (xs @ ys) = takeWhile P xs"
by auto

lemma takeWhile_takeWhile: "takeWhile P (takeWhile Q xs) = takeWhile (λx. P x  Q x) xs"
by(induct xs) simp_all

lemma dropWhile_eq_ConsD:
  "dropWhile P xs = y # ys  y  set xs  ¬ P y"
by(induct xs)(auto split: if_split_asm)

lemma dropWhile_eq_hd_conv: "dropWhile P xs = hd xs # rest  xs  []  rest = tl xs  ¬ P (hd xs)"
by (metis append_Nil append_is_Nil_conv dropWhile_eq_Cons_conv list.sel(1) neq_Nil_conv takeWhile_dropWhile_id takeWhile_eq_Nil_conv list.sel(3))

lemma dropWhile_eq_same_conv: "dropWhile P xs = xs  (xs = []  ¬ P (hd xs))"
by (metis dropWhile.simps(1) eq_Nil_appendI hd_dropWhile takeWhile_dropWhile_id takeWhile_eq_Nil_conv)

lemma subset_code [code_unfold]:
  "set xs  set ys  (x  set xs. x  set ys)"
by(rule Set.subset_eq)

lemma eval_bot [simp]:
  "Predicate.eval bot = (λ_. False)"
by(auto simp add: fun_eq_iff)

lemma not_is_emptyE:
  assumes "¬ Predicate.is_empty P"
  obtains x where "Predicate.eval P x"
using assms
by(fastforce simp add: Predicate.is_empty_def bot_pred_def intro!: pred_iffI)

lemma is_emptyD:
  assumes "Predicate.is_empty P"
  shows "Predicate.eval P x  False"
using assms
by(simp add: Predicate.is_empty_def bot_pred_def bot_apply Set.empty_def)

lemma eval_bind_conv:
  "Predicate.eval (P  R) y = (x. Predicate.eval P x  Predicate.eval (R x) y)"
by(blast elim: bindE intro: bindI)

lemma eval_single_conv: "Predicate.eval (Predicate.single a) b  a = b"
by(blast intro: singleI elim: singleE)


lemma conj_asm_conv_imp:
  "(A  B  PROP C)  (A  B  PROP C)" 
apply(rule equal_intr_rule)
 apply(erule meta_mp)
 apply(erule (1) conjI)
apply(erule meta_impE)
 apply(erule conjunct1)
apply(erule meta_mp)
apply(erule conjunct2)
done

lemma meta_all_eq_conv: "(a. a = b  PROP P a)  PROP P b"
apply(rule equal_intr_rule)
 apply(erule meta_allE)
 apply(erule meta_mp)
 apply(rule refl)
apply(hypsubst)
apply assumption
done

lemma meta_all_eq_conv2: "(a. b = a  PROP P a)  PROP P b"
apply(rule equal_intr_rule)
 apply(erule meta_allE)
 apply(erule meta_mp)
 apply(rule refl)
apply(hypsubst)
apply assumption
done

lemma disj_split:
  "P (a  b)  (a  P True)  (b  P True)  (¬ a  ¬ b  P False)"
apply(cases a)
apply(case_tac [!] b)
apply auto
done

lemma disj_split_asm:
  "P (a  b)  ¬ (a  ¬ P True  b  ¬ P True  ¬ a  ¬ b  ¬ P False)"
apply(auto simp add: disj_split[of P])
done

lemma disjCE:
  assumes "P  Q"
  obtains P | "Q" "¬ P"
using assms by blast

lemma case_option_conv_if:
  "(case v of None  f | Some x  g x) = (if a. v = Some a then g (the v) else f)"
by(simp)

lemma LetI: "(x. x = t  P x)  let x = t in P x"
by(simp)

(* rearrange parameters and premises to allow application of one-point-rules *)
(* adapted from Tools/induct.ML and Isabelle Developer Workshop 2010 *)

simproc_setup rearrange_eqs ("Pure.all t") = let
  fun swap_params_conv ctxt i j cv =
    let
      fun conv1 0 ctxt = Conv.forall_conv (cv o snd) ctxt
        | conv1 k ctxt =
            Conv.rewr_conv @{thm swap_params} then_conv
            Conv.forall_conv (conv1 (k - 1) o snd) ctxt
      fun conv2 0 ctxt = conv1 j ctxt
        | conv2 k ctxt = Conv.forall_conv (conv2 (k - 1) o snd) ctxt
    in conv2 i ctxt end;

  fun swap_prems_conv 0 = Conv.all_conv
    | swap_prems_conv i =
        Conv.implies_concl_conv (swap_prems_conv (i - 1)) then_conv
        Conv.rewr_conv Drule.swap_prems_eq;

  fun find_eq ctxt t =
    let
      val l = length (Logic.strip_params t);
      val Hs = Logic.strip_assums_hyp t;
      fun find (i, (_ $ (Const ("HOL.eq", _) $ Bound j $ _))) = SOME (i, j)
        | find (i, (_ $ (Const ("HOL.eq", _) $ _ $ Bound j))) = SOME (i, j)
        | find _ = NONE
    in
      (case get_first find (map_index I Hs) of
        NONE => NONE
      | SOME (0, 0) => NONE
      | SOME (i, j) => SOME (i, l - j - 1, j))
    end;

  fun mk_swap_rrule ctxt ct =
    (case find_eq ctxt (Thm.term_of ct) of
      NONE => NONE
    | SOME (i, k, j) => SOME (swap_params_conv ctxt k j (K (swap_prems_conv i)) ct))
in
  fn _ => mk_swap_rrule
end
declare [[simproc del: rearrange_eqs]]
lemmas meta_onepoint = meta_all_eq_conv meta_all_eq_conv2

lemma meta_all2_eq_conv: "(a b. a = c  PROP P a b)  (b. PROP P c b)"
apply(rule equal_intr_rule)
 apply(erule meta_allE)+
 apply(erule meta_mp)
 apply(rule refl)
apply(erule meta_allE)
apply simp
done

lemma meta_all3_eq_conv: "(a b c. a = d  PROP P a b c)  (b c. PROP P d b c)"
apply(rule equal_intr_rule)
 apply(erule meta_allE)+
 apply(erule meta_mp)
 apply(rule refl)
apply(erule meta_allE)+
apply simp
done

lemma meta_all4_eq_conv: "(a b c d. a = e  PROP P a b c d)  (b c d. PROP P e b c d)"
apply(rule equal_intr_rule)
 apply(erule meta_allE)+
 apply(erule meta_mp)
 apply(rule refl)
apply(erule meta_allE)+
apply simp
done

lemma meta_all5_eq_conv: "(a b c d e. a = f  PROP P a b c d e)  (b c d e. PROP P f b c d e)"
apply(rule equal_intr_rule)
 apply(erule meta_allE)+
 apply(erule meta_mp)
 apply(rule refl)
apply(erule meta_allE)+
apply simp
done

lemma inj_on_image_mem_iff:
  " inj_on f A; B  A; a  A   f a  f ` B  a  B"
by(metis inv_into_f_eq inv_into_image_cancel rev_image_eqI)

lemma sum_hom:
  assumes hom_add [simp]: "a b. f (a + b) = f a + f b"
  and hom_0 [simp]: "f 0 = 0"
  shows "sum (f  h) A = f (sum h A)"
proof(cases "finite A")
  case False thus ?thesis by simp
next
  case True thus ?thesis
    by(induct) simp_all
qed

lemma sum_upto_add_nat:
  "a  b  sum f {..<(a :: nat)} + sum f {a..<b} = sum f {..<b}"
by (metis atLeast0LessThan le0 sum.atLeastLessThan_concat)

lemma nat_fun_sum_eq_conv:
  fixes f :: "'a  nat"
  shows "(λa. f a + g a) = (λa. 0)  f = (λa .0)  g = (λa. 0)"
by(auto simp add: fun_eq_iff)


lemma in_ran_conv: "v  ran m  (k. m k = Some v)"
by(simp add: ran_def)

lemma map_le_dom_eq_conv_eq:
  " m m m'; dom m = dom m'   m = m'"
by (metis map_le_antisym map_le_def)

lemma map_leI:
  "(k v. f k = Some v  g k = Some v)  f m g"
unfolding map_le_def by auto

lemma map_le_SomeD: " m m m'; m x = y   m' x = y"
by(auto simp add: map_le_def dest: bspec)

lemma map_le_same_upd:
  "f x = None  f m f(x  y)"
by(auto simp add: map_le_def)

lemma map_upd_map_add: "X(V  v) = (X ++ [V  v])"
by(simp)




lemma foldr_filter_conv:
  "foldr f (filter P xs) = foldr (λx s. if P x then f x s else s) xs"
by(induct xs)(auto intro: ext)

lemma foldr_insert_conv_set:
  "foldr insert xs A = A  set xs"
by(induct xs arbitrary: A) auto

lemma snd_o_Pair_conv_id: "snd o Pair a = id"
by(simp add: o_def id_def)

lemma if_intro:
  " P  A; ¬ P  B   if P then A else B"
by(auto)

lemma ex_set_conv: "(x. x  set xs)  xs  []"
apply(auto)
apply(auto simp add: neq_Nil_conv)
done

lemma subset_Un1: "A  B  A  B  C" by blast
lemma subset_Un2: "A  C  A  B  C" by blast
lemma subset_insert: "A  B  A  insert a B" by blast
lemma UNION_subsetD: " (xA. f x)  B; a  A   f a  B" by blast

lemma Collect_eq_singleton_conv:
  "{a. P a} = {a}  P a  (a'. P a'  a = a')"
by(auto)

lemma Collect_conv_UN_singleton: "{f x|x. x  P} = (xP. {f x})"
by blast

lemma if_else_if_else_eq_if_else [simp]:
  "(if b then x else if b then y else z) = (if b then x else z)"
by(simp)

lemma rec_prod_split [simp]: "old.rec_prod = case_prod"
by(simp add: fun_eq_iff)

lemma inj_Pair_snd [simp]: "inj (Pair x)"
by(rule injI) auto

lemma rtranclp_False [simp]: "(λa b. False)** = (=)"
by(auto simp add: fun_eq_iff elim: rtranclp_induct)

lemmas rtranclp_induct3 =
  rtranclp_induct[where a="(ax, ay, az)" and b="(bx, by, bz)", split_rule, consumes 1, case_names refl step]

lemmas tranclp_induct3 =
  tranclp_induct[where a="(ax, ay, az)" and b="(bx, by, bz)", split_rule, consumes 1, case_names refl step]

lemmas rtranclp_induct4 =
  rtranclp_induct[where a="(ax, ay, az, aw)" and b="(bx, by, bz, bw)", split_rule, consumes 1, case_names refl step]

lemmas tranclp_induct4 =
  tranclp_induct[where a="(ax, ay, az, aw)" and b="(bx, by, bz, bw)", split_rule, consumes 1, case_names refl step]

lemmas converse_tranclp_induct2 =
  converse_tranclp_induct [of _ "(ax,ay)" "(bx,by)", split_rule,
                 consumes 1, case_names base step]

lemma wfP_induct' [consumes 1, case_names wfP]:
  "wfP r; x. (y. r y x  P y)  P x  P a"
by(blast intro: wfP_induct)

lemma wfP_induct2 [consumes 1, case_names wfP]:
  "wfP r; x x'. (y y'. r (y, y') (x, x')  P y y')  P x x'   P x x'"
by(drule wfP_induct'[where P="λ(x, y). P x y"]) blast+

lemma wfP_minimalE:
  assumes "wfP r"
  and "P x"
  obtains z where "P z" "r^** z x" "y. r y z  ¬ P y"
proof -
  let ?Q = "λx'. P x'  r^** x' x"
  from P x have "?Q x" by blast
  from ‹wfP r have "Q. x  Q  (zQ. y. r y z  y  Q)"
    unfolding wfP_eq_minimal by blast
  from this[rule_format, of "Collect ?Q"] ?Q x
  obtain z where "?Q z" and min: "y. r y z  ¬ ?Q y" by auto
  from ?Q z have "P z" "r^** z x" by auto
  moreover
  { fix y
    assume "r y z"
    hence "¬ ?Q y" by(rule min)
    moreover from r y z r^** z x have "r^** y x"
      by(rule converse_rtranclp_into_rtranclp)
    ultimately have "¬ P y" by blast }
  ultimately show thesis ..
qed

lemma coinduct_set_wf [consumes 3, case_names coinduct, case_conclusion coinduct wait step]: 
  assumes "mono f" "wf r" "(a, b)  X"
  and step: "x b. (x, b)  X  (b'. (b', b)  r  (x, b')  X)  (x  f (fst ` X  gfp f))"
  shows "a  gfp f"
proof -
  from (a, b)  X have "a  fst ` X" by(auto intro: rev_image_eqI)
  moreover
  { fix a b
    assume "(a, b)  X"
    with ‹wf r have "a  f (fst ` X  gfp f)"
      by(induct)(blast dest: step) }
  hence "fst ` X  f (fst ` X  gfp f)" by(auto)
  ultimately show ?thesis by(rule coinduct_set[OF ‹mono f])
qed

subsection ‹reflexive transitive closure for label relations›

inductive converse3p :: "('a  'b  'c  bool)  'c  'b  'a  bool"
  for r :: "'a  'b  'c  bool"
where
  converse3pI: "r a b c  converse3p r c b a"

lemma converse3p_converse3p: "converse3p (converse3p r) = r"
by(auto intro: converse3pI intro!: ext elim: converse3p.cases)

lemma converse3pD: "converse3p r c b a  r a b c"
by(auto elim: converse3p.cases)

inductive rtrancl3p :: "('a  'b  'a  bool)  'a  'b list  'a  bool"
  for r :: "'a  'b  'a  bool"
  where 
  rtrancl3p_refl [intro!, simp]: "rtrancl3p r a [] a"
| rtrancl3p_step: " rtrancl3p r a bs a'; r a' b a''   rtrancl3p r a (bs @ [b]) a''"

lemmas rtrancl3p_induct3 =
  rtrancl3p.induct[of _ "(ax,ay,az)" _ "(cx,cy,cz)", split_format (complete),
                 consumes 1, case_names refl step]

lemmas rtrancl3p_induct4 = 
  rtrancl3p.induct[of _ "(ax,ay,az,aw)" _ "(cx,cy,cz,cw)", split_format (complete),
                 consumes 1, case_names refl step]

lemma rtrancl3p_induct4' [consumes 1, case_names refl step]:
  assumes major: "rtrancl3p r (ax, (ay, az), aw) bs (cx, (cy, cz), cw)"
  and refl: "a aa b ba. P a aa b ba [] a aa b ba"
  and step: "a aa b ba bs ab ac bb bc bd ad ae be bf.
        rtrancl3p r (a, (aa, b), ba) bs (ab, (ac, bb), bc);
         P a aa b ba bs ab ac bb bc; r (ab, (ac, bb), bc) bd (ad, (ae, be), bf) 
        P a aa b ba (bs @ [bd]) ad ae be bf"
  shows "P ax ay az aw bs cx cy cz cw"
using major
apply -
apply(drule_tac P="λ(a, (aa, b), ba) bs (cx, (cy, cz), cw). P a aa b ba bs cx cy cz cw" in rtrancl3p.induct)
by(auto intro: refl step)

lemma rtrancl3p_induct1:
  " rtrancl3p r a bs c; P a; bs c b d.  rtrancl3p r a bs c; r c b d; P c   P d   P c"
apply(induct rule: rtrancl3p.induct)
apply(auto)
done

inductive_cases rtrancl3p_cases:
  "rtrancl3p r x [] y"
  "rtrancl3p r x (b # bs) y"

lemma rtrancl3p_trans [trans]:
  assumes one: "rtrancl3p r a bs a'"
  and two: "rtrancl3p r a' bs' a''"
  shows "rtrancl3p r a (bs @ bs') a''"
using two one
proof(induct rule: rtrancl3p.induct)
  case rtrancl3p_refl thus ?case by simp
next
  case rtrancl3p_step thus ?case
    by(auto simp only: append_assoc[symmetric] intro: rtrancl3p.rtrancl3p_step)
qed

lemma rtrancl3p_step_converse:
  assumes step: "r a b a'"
  and stepify: "rtrancl3p r a' bs a''"
  shows "rtrancl3p r a (b # bs) a''"
using stepify step
proof(induct rule: rtrancl3p.induct)
  case rtrancl3p_refl 
  with rtrancl3p.rtrancl3p_refl[where r=r and a=a] show ?case 
    by(auto dest: rtrancl3p.rtrancl3p_step simp del: rtrancl3p.rtrancl3p_refl)
next
  case rtrancl3p_step thus ?case
    unfolding append_Cons[symmetric]
    by -(rule rtrancl3p.rtrancl3p_step)
qed

lemma converse_rtrancl3p_step:
  "rtrancl3p r a (b # bs) a''  a'. r a b a'  rtrancl3p r a' bs a''"
apply(induct bs arbitrary: a'' rule: rev_induct)
 apply(erule rtrancl3p.cases)
  apply(clarsimp)+
 apply(erule rtrancl3p.cases)
  apply(clarsimp)
  apply(rule_tac x="a''a" in exI)
  apply(clarsimp)
 apply(clarsimp)
apply(erule rtrancl3p.cases)
 apply(clarsimp)
apply(clarsimp)
by(fastforce intro: rtrancl3p_step)

lemma converse_rtrancl3pD:
  "rtrancl3p (converse3p r) a' bs a  rtrancl3p r a (rev bs) a'"
apply(induct rule: rtrancl3p.induct)
 apply(fastforce intro: rtrancl3p.intros)
apply(auto dest: converse3pD intro: rtrancl3p_step_converse)
done

lemma rtrancl3p_converseD:
  "rtrancl3p r a bs a'  rtrancl3p (converse3p r) a' (rev bs) a"
proof(induct rule: rtrancl3p.induct)
  case rtrancl3p_refl thus ?case
    by(auto intro: rtrancl3p.intros)
next
  case rtrancl3p_step thus ?case
    by(auto intro: rtrancl3p_step_converse converse3p.intros)
qed

lemma rtrancl3p_converse_induct [consumes 1, case_names refl step]:
  assumes ih: "rtrancl3p r a bs a''"
  and refl: "a. P a [] a"
  and step: "a b a' bs a''.  rtrancl3p r a' bs a''; r a b a'; P a' bs a''   P a (b # bs) a''"
  shows "P a bs a''"
  using ih
proof(induct bs arbitrary: a a'')
  case Nil thus ?case
    by(auto elim: rtrancl3p.cases intro: refl)
next
  case Cons thus ?case
    by(auto dest!: converse_rtrancl3p_step intro: step)
qed  

lemma rtrancl3p_converse_induct' [consumes 1, case_names refl step]:
  assumes ih: "rtrancl3p r a bs a''"
  and refl: "P a'' []"
  and step: "a b a' bs.  rtrancl3p r a' bs a''; r a b a'; P a' bs   P a (b # bs)"
  shows "P a bs"
using rtrancl3p_converse_induct[OF ih, where P="λa bs a'. a' = a''  P a bs"]
by(auto intro: refl step)

lemma rtrancl3p_converseE[consumes 1, case_names refl step]:
  " rtrancl3p r a bs a'';
      a = a''; bs = []   thesis;
     bs' b a'.  bs = b # bs'; r a b a'; rtrancl3p r a' bs' a''   thesis 
   thesis"
by(induct rule: rtrancl3p_converse_induct)(auto)


lemma rtrancl3p_induct' [consumes 1, case_names refl step]:
  assumes major: "rtrancl3p r a bs c"
  and refl: "P a [] a"
  and step: "bs a' b a''.  rtrancl3p r a bs a'; P a bs a'; r a' b a'' 
              P a (bs @ [b]) a''"
  shows "P a bs c"
proof -
  from major have "(P a [] a  (bs a' b a''. rtrancl3p r a bs a'  P a bs a'  r a' b a''  P a (bs @ [b]) a''))  P a bs c"
    by-(erule rtrancl3p.induct, blast+)
  with refl step show ?thesis by blast
qed

lemma r_into_rtrancl3p:
  "r a b a'  rtrancl3p r a [b] a'"
by(rule rtrancl3p_step_converse) auto

lemma rtrancl3p_appendE:
  assumes "rtrancl3p r a (bs @ bs') a''"
  obtains a' where "rtrancl3p r a bs a'" "rtrancl3p r a' bs' a''"
using assms
apply(induct a "bs @ bs'" arbitrary: bs rule: rtrancl3p_converse_induct')
apply(fastforce intro: rtrancl3p_step_converse simp add: Cons_eq_append_conv)+
done

lemma rtrancl3p_Cons:
  "rtrancl3p r a (b # bs) a'  (a''. r a b a''  rtrancl3p r a'' bs a')"
by(auto intro: rtrancl3p_step_converse converse_rtrancl3p_step)

lemma rtrancl3p_Nil:
  "rtrancl3p r a [] a'  a = a'"
by(auto elim: rtrancl3p_cases)

definition invariant3p :: "('a  'b  'a  bool)  'a set  bool"
where "invariant3p r I  (s tl s'. s  I  r s tl s'  s'  I)"

lemma invariant3pI: "(s tl s'.  s  I; r s tl s'   s'  I)  invariant3p r I"
unfolding invariant3p_def by blast

lemma invariant3pD: "tl.  invariant3p r I; r s tl s'; s  I   s'  I"
unfolding invariant3p_def by(blast)

lemma invariant3p_rtrancl3p: 
  assumes inv: "invariant3p r I"
  and rtrancl: "rtrancl3p r a bs a'"
  and start: "a  I"
  shows "a'  I"
using rtrancl start by(induct)(auto dest: invariant3pD[OF inv])

lemma invariant3p_UNIV [simp, intro!]:
  "invariant3p r UNIV"
by(blast intro: invariant3pI)

lemma invarinat3p_empty [simp, intro!]:
  "invariant3p r {}"
by(blast intro: invariant3pI)

lemma invariant3p_IntI [simp, intro]:
  " invariant3p r I; invariant3p r J   invariant3p r (I  J)"
by(blast dest: invariant3pD intro: invariant3pI)

subsection ‹Concatenation for @{typ String.literal}

definition concat :: "String.literal list  String.literal"
  where [code_abbrev, code del]: "concat = sum_list"

lemma explode_add [simp]:
  "String.explode (s + t) = String.explode s @ String.explode t"
  by (fact plus_literal.rep_eq)

code_printing
  constant concat 
    (SML) "String.concat"
    and (Haskell) "concat"
    and (OCaml) "String.concat \"\""

hide_const (open) concat

end

Theory Basic_Main

theory Basic_Main
imports Main
  "HOL-Library.Sublist"
  "HOL-Library.Transitive_Closure_Table"
  "HOL-Library.Predicate_Compile_Alternative_Defs"
  "HOL-Library.Dlist"
  Set_without_equal
  Set_Monad
  Coinductive.Lazy_TLList

  (*
  "../../Collections/impl/ListSetImpl_Invar"
  "../../Collections/impl/RBTSetImpl"
  "../../Collections/impl/TrieMapImpl"
  "../../Collections/impl/ListMapImpl"
  "../../Collections/impl/Fifo"
  *)
  "../Basic/JT_ICF"
  
  Auxiliary
begin

end

Theory FWState

(*  Title:      JinjaThreads/Framework/FWState.thy
    Author:     Andreas Lochbihler
*)

chapter ‹The generic multithreaded semantics›

section ‹State of the multithreaded semantics›

theory FWState
imports 
  "../Basic/Auxiliary"
begin

datatype lock_action =
    Lock
  | Unlock
  | UnlockFail
  | ReleaseAcquire

datatype ('t,'x,'m) new_thread_action =
    NewThread 't 'x 'm
  | ThreadExists 't bool

datatype 't conditional_action = 
    Join 't
  | Yield

datatype ('t, 'w) wait_set_action =
    Suspend 'w
  | Notify 'w
  | NotifyAll 'w
  | WakeUp 't
  | Notified
  | WokenUp

datatype 't interrupt_action 
  = IsInterrupted 't bool
  | Interrupt 't
  | ClearInterrupt 't

type_synonym 'l lock_actions = "'l ⇒f lock_action list"

translations
  (type) "'l lock_actions" <= (type) "'l ⇒f lock_action list"

type_synonym
  ('l,'t,'x,'m,'w,'o) thread_action =
  "'l lock_actions × ('t,'x,'m) new_thread_action list ×
   't conditional_action list × ('t, 'w) wait_set_action list × 
   't interrupt_action list × 'o list"
(* pretty printing for thread_action type *)
print_translation let
    fun tr'
       [Const (@{type_syntax finfun}, _) $ l $
          (Const (@{type_syntax list}, _) $ Const (@{type_syntax lock_action}, _)),
        Const (@{type_syntax "prod"}, _) $
          (Const (@{type_syntax list}, _) $ (Const (@{type_syntax new_thread_action}, _) $ t1 $ x $ m)) $
          (Const (@{type_syntax "prod"}, _) $
            (Const (@{type_syntax list}, _) $ (Const (@{type_syntax conditional_action}, _) $ t2)) $
            (Const (@{type_syntax "prod"}, _) $
              (Const (@{type_syntax list}, _) $ (Const (@{type_syntax wait_set_action}, _) $ t3 $ w)) $ 
              (Const (@{type_syntax "prod"}, _) $
                 (Const (@{type_syntax "list"}, _) $ (Const (@{type_syntax "interrupt_action"}, _) $ t4)) $
                 (Const (@{type_syntax "list"}, _) $ o1))))] =
      if t1 = t2 andalso t2 = t3 andalso t3 = t4 then Syntax.const @{type_syntax thread_action} $ l $ t1 $ x $ m $ w $ o1
      else raise Match;
  in [(@{type_syntax "prod"}, K tr')]
  end
typ "('l,'t,'x,'m,'w,'o) thread_action"
 
definition locks_a :: "('l,'t,'x,'m,'w,'o) thread_action  'l lock_actions" ("_l" [0] 1000) where
  "locks_a  fst"

definition thr_a :: "('l,'t,'x,'m,'w,'o) thread_action  ('t,'x,'m) new_thread_action list" ("_t" [0] 1000) where
  "thr_a  fst o snd"

definition cond_a :: "('l,'t,'x,'m,'w,'o) thread_action  't conditional_action list" ("_c" [0] 1000) where
  "cond_a = fst o snd o snd"

definition wset_a :: "('l,'t,'x,'m,'w,'o) thread_action  ('t, 'w) wait_set_action list" ("_w" [0] 1000) where
  "wset_a = fst o snd o snd o snd" 

definition interrupt_a :: "('l,'t,'x,'m,'w,'o) thread_action  't interrupt_action list" ("_i" [0] 1000) where
  "interrupt_a = fst o snd o snd o snd o snd"

definition obs_a :: "('l,'t,'x,'m,'w,'o) thread_action  'o list" ("_o" [0] 1000) where
  "obs_a  snd o snd o snd o snd o snd"

lemma locks_a_conv [simp]: "locks_a (ls, ntsjswss) = ls"
by(simp add:locks_a_def)

lemma thr_a_conv [simp]: "thr_a (ls, nts, jswss) = nts"
by(simp add: thr_a_def)

lemma cond_a_conv [simp]: "cond_a (ls, nts, js, wws) = js"
by(simp add: cond_a_def)

lemma wset_a_conv [simp]: "wset_a (ls, nts, js, wss, isobs) = wss"
by(simp add: wset_a_def)

lemma interrupt_a_conv [simp]: "interrupt_a (ls, nts, js, ws, is, obs) = is"
by(simp add: interrupt_a_def)

lemma obs_a_conv [simp]: "obs_a (ls, nts, js, wss, is, obs) = obs"
by(simp add: obs_a_def)

fun ta_update_locks :: "('l,'t,'x,'m,'w,'o) thread_action  lock_action  'l  ('l,'t,'x,'m,'w,'o) thread_action" where
  "ta_update_locks (ls, nts, js, wss, obs) lta l = (ls(l $:= ls $ l @ [lta]), nts, js, wss, obs)"

fun ta_update_NewThread :: "('l,'t,'x,'m,'w,'o) thread_action  ('t,'x,'m) new_thread_action  ('l,'t,'x,'m,'w,'o) thread_action" where
  "ta_update_NewThread (ls, nts, js, wss, is, obs) nt = (ls, nts @ [nt], js, wss, is, obs)"

fun ta_update_Conditional :: "('l,'t,'x,'m,'w,'o) thread_action  't conditional_action  ('l,'t,'x,'m,'w,'o) thread_action"
where
  "ta_update_Conditional (ls, nts, js, wss, is, obs) j = (ls, nts, js @ [j], wss, is, obs)"

fun ta_update_wait_set :: "('l,'t,'x,'m,'w,'o) thread_action  ('t, 'w) wait_set_action  ('l,'t,'x,'m,'w,'o) thread_action" where
  "ta_update_wait_set (ls, nts, js, wss, is, obs) ws = (ls, nts, js, wss @ [ws], is, obs)"

fun ta_update_interrupt :: "('l,'t,'x,'m,'w,'o) thread_action  't interrupt_action  ('l,'t,'x,'m,'w,'o) thread_action"
where
  "ta_update_interrupt (ls, nts, js, wss, is, obs) i = (ls, nts, js, wss, is @ [i], obs)"

fun ta_update_obs :: "('l,'t,'x,'m,'w,'o) thread_action  'o  ('l,'t,'x,'m,'w,'o) thread_action"
where
  "ta_update_obs (ls, nts, js, wss, is, obs) ob = (ls, nts, js, wss, is, obs @ [ob])"

abbreviation empty_ta :: "('l,'t,'x,'m,'w,'o) thread_action" where
  "empty_ta  (K$ [], [], [], [], [], [])"

notation (input) empty_ta ("ε")

text ‹
  Pretty syntax for specifying thread actions:
  Write ⦃ Lock→l, Unlock→l, Suspend w, Interrupt t⦄› instead of
  @{term "((K$ [])(l $:= [Lock, Unlock]), [], [Suspend w], [Interrupt t], [])"}.

  thread_action'› is a type that contains of all basic thread actions.
  Automatically coerce basic thread actions into that type and then dispatch to the right
  update function by pattern matching.
  For coercion, adhoc overloading replaces the generic injection inject_thread_action›
  by the specific ones, i.e. constructors.
  To avoid ambiguities with observable actions, the observable actions must be of sort obs_action›,
  which the basic thread action types are not.
›

class obs_action

datatype ('l,'t,'x,'m,'w,'o) thread_action' 
  = LockAction "lock_action × 'l"
  | NewThreadAction "('t,'x,'m) new_thread_action"
  | ConditionalAction "'t conditional_action"
  | WaitSetAction "('t, 'w) wait_set_action"
  | InterruptAction "'t interrupt_action"
  | ObsAction 'o

setup ‹
  Sign.add_const_constraint (@{const_name ObsAction}, SOME @{typ "'o :: obs_action  ('l,'t,'x,'m,'w,'o) thread_action'"})

fun thread_action'_to_thread_action :: 
  "('l,'t,'x,'m,'w,'o :: obs_action) thread_action'  ('l,'t,'x,'m,'w,'o) thread_action  ('l,'t,'x,'m,'w,'o) thread_action"
where
  "thread_action'_to_thread_action (LockAction (la, l)) ta = ta_update_locks ta la l"
| "thread_action'_to_thread_action (NewThreadAction nt) ta = ta_update_NewThread ta nt"
| "thread_action'_to_thread_action (ConditionalAction ca) ta = ta_update_Conditional ta ca"
| "thread_action'_to_thread_action (WaitSetAction wa) ta = ta_update_wait_set ta wa"
| "thread_action'_to_thread_action (InterruptAction ia) ta = ta_update_interrupt ta ia"
| "thread_action'_to_thread_action (ObsAction ob) ta = ta_update_obs ta ob"

consts inject_thread_action :: "'a  ('l,'t,'x,'m,'w,'o) thread_action'"

nonterminal ta_let and ta_lets
syntax
  "_ta_snoc" :: "ta_lets  ta_let  ta_lets" ("_,/ _")
  "_ta_block" :: "ta_lets  'a" ("_" [0] 1000)
  "_ta_empty" :: "ta_lets" ("") 
  "_ta_single" :: "ta_let  ta_lets" ("_")
  "_ta_inject" :: "logic  ta_let" ("(_)")
  "_ta_lock" :: "logic  logic  ta_let" ("__")

translations
  "_ta_block _ta_empty" == "CONST empty_ta"
  "_ta_block (_ta_single bta)" == "_ta_block (_ta_snoc _ta_empty bta)"
  "_ta_inject bta" == "CONST inject_thread_action bta"
  "_ta_lock la l" == "CONST inject_thread_action (CONST Pair la l)"
  "_ta_block (_ta_snoc btas bta)" == "CONST thread_action'_to_thread_action bta (_ta_block btas)"


adhoc_overloading
  inject_thread_action NewThreadAction ConditionalAction WaitSetAction InterruptAction ObsAction LockAction

lemma ta_upd_proj_simps [simp]:
  shows ta_obs_proj_simps:
  "ta_update_obs ta obsl = tal" "ta_update_obs ta obst = tat" "ta_update_obs ta obsw = taw" 
  "ta_update_obs ta obsc = tac" "ta_update_obs ta obsi = tai" "ta_update_obs ta obso = tao @ [obs]"
  and ta_lock_proj_simps:
  "ta_update_locks ta x ll = (let ls = tal in ls(l $:= ls $ l @ [x]))"
  "ta_update_locks ta x lt = tat" "ta_update_locks ta x lw = taw" "ta_update_locks ta x lc = tac" 
  "ta_update_locks ta x li = tai" "ta_update_locks ta x lo = tao"
  and ta_thread_proj_simps:
  "ta_update_NewThread ta tl = tal" "ta_update_NewThread ta tt = tat @ [t]" "ta_update_NewThread ta tw = taw" 
  "ta_update_NewThread ta tc = tac" "ta_update_NewThread ta ti = tai" "ta_update_NewThread ta to = tao"
  and ta_wset_proj_simps:
  "ta_update_wait_set ta wl = tal" "ta_update_wait_set ta wt = tat" "ta_update_wait_set ta ww = taw @ [w]"
  "ta_update_wait_set ta wc = tac" "ta_update_wait_set ta wi = tai" "ta_update_wait_set ta wo = tao"
  and ta_cond_proj_simps:
  "ta_update_Conditional ta cl = tal" "ta_update_Conditional ta ct = tat" "ta_update_Conditional ta cw = taw"
  "ta_update_Conditional ta cc = tac @ [c]" "ta_update_Conditional ta ci = tai" "ta_update_Conditional ta co = tao"
  and ta_interrupt_proj_simps:
  "ta_update_interrupt ta il = tal" "ta_update_interrupt ta it = tat" "ta_update_interrupt ta ic = tac"
  "ta_update_interrupt ta iw = taw" "ta_update_interrupt ta ii = tai @ [i]" "ta_update_interrupt ta io = tao"
by(cases ta, simp)+

lemma thread_action'_to_thread_action_proj_simps [simp]:
  shows thread_action'_to_thread_action_proj_locks_simps:
  "thread_action'_to_thread_action (LockAction (la, l)) tal = ta_update_locks ta la ll"
  "thread_action'_to_thread_action (NewThreadAction nt) tal = ta_update_NewThread ta ntl"
  "thread_action'_to_thread_action (ConditionalAction ca) tal = ta_update_Conditional ta cal"
  "thread_action'_to_thread_action (WaitSetAction wa) tal = ta_update_wait_set ta wal"
  "thread_action'_to_thread_action (InterruptAction ia) tal = ta_update_interrupt ta ial"
  "thread_action'_to_thread_action (ObsAction ob) tal = ta_update_obs ta obl"
  and thread_action'_to_thread_action_proj_nt_simps:
  "thread_action'_to_thread_action (LockAction (la, l)) tat = ta_update_locks ta la lt"
  "thread_action'_to_thread_action (NewThreadAction nt) tat = ta_update_NewThread ta ntt"
  "thread_action'_to_thread_action (ConditionalAction ca) tat = ta_update_Conditional ta cat"
  "thread_action'_to_thread_action (WaitSetAction wa) tat = ta_update_wait_set ta wat"
  "thread_action'_to_thread_action (InterruptAction ia) tat = ta_update_interrupt ta iat"
  "thread_action'_to_thread_action (ObsAction ob) tat = ta_update_obs ta obt"
  and thread_action'_to_thread_action_proj_cond_simps:
  "thread_action'_to_thread_action (LockAction (la, l)) tac = ta_update_locks ta la lc"
  "thread_action'_to_thread_action (NewThreadAction nt) tac = ta_update_NewThread ta ntc"
  "thread_action'_to_thread_action (ConditionalAction ca) tac = ta_update_Conditional ta cac"
  "thread_action'_to_thread_action (WaitSetAction wa) tac = ta_update_wait_set ta wac"
  "thread_action'_to_thread_action (InterruptAction ia) tac = ta_update_interrupt ta iac"
  "thread_action'_to_thread_action (ObsAction ob) tac = ta_update_obs ta obc"
  and thread_action'_to_thread_action_proj_wset_simps:
  "thread_action'_to_thread_action (LockAction (la, l)) taw = ta_update_locks ta la lw"
  "thread_action'_to_thread_action (NewThreadAction nt) taw = ta_update_NewThread ta ntw"
  "thread_action'_to_thread_action (ConditionalAction ca) taw = ta_update_Conditional ta caw"
  "thread_action'_to_thread_action (WaitSetAction wa) taw = ta_update_wait_set ta waw"
  "thread_action'_to_thread_action (InterruptAction ia) taw = ta_update_interrupt ta iaw"
  "thread_action'_to_thread_action (ObsAction ob) taw = ta_update_obs ta obw"
  and thread_action'_to_thread_action_proj_interrupt_simps:
  "thread_action'_to_thread_action (LockAction (la, l)) tai = ta_update_locks ta la li"
  "thread_action'_to_thread_action (NewThreadAction nt) tai = ta_update_NewThread ta nti"
  "thread_action'_to_thread_action (ConditionalAction ca) tai = ta_update_Conditional ta cai"
  "thread_action'_to_thread_action (WaitSetAction wa) tai = ta_update_wait_set ta wai"
  "thread_action'_to_thread_action (InterruptAction ia) tai = ta_update_interrupt ta iai"
  "thread_action'_to_thread_action (ObsAction ob) tai = ta_update_obs ta obi"
  and thread_action'_to_thread_action_proj_obs_simps:
  "thread_action'_to_thread_action (LockAction (la, l)) tao = ta_update_locks ta la lo"
  "thread_action'_to_thread_action (NewThreadAction nt) tao = ta_update_NewThread ta nto"
  "thread_action'_to_thread_action (ConditionalAction ca) tao = ta_update_Conditional ta cao"
  "thread_action'_to_thread_action (WaitSetAction wa) tao = ta_update_wait_set ta wao"
  "thread_action'_to_thread_action (InterruptAction ia) tao = ta_update_interrupt ta iao"
  "thread_action'_to_thread_action (ObsAction ob) tao = ta_update_obs ta obo"
by(simp_all)

lemmas ta_upd_simps =
  ta_update_locks.simps ta_update_NewThread.simps ta_update_Conditional.simps
  ta_update_wait_set.simps ta_update_interrupt.simps ta_update_obs.simps
  thread_action'_to_thread_action.simps

declare ta_upd_simps [simp del]

hide_const (open)
  LockAction NewThreadAction ConditionalAction WaitSetAction InterruptAction ObsAction
  thread_action'_to_thread_action
hide_type (open) thread_action'

datatype wake_up_status =
  WSNotified
| WSWokenUp

datatype 'w wait_set_status =
  InWS 'w
| PostWS wake_up_status

type_synonym 't lock = "('t × nat) option"
type_synonym ('l,'t) locks = "'l ⇒f 't lock"
type_synonym 'l released_locks = "'l ⇒f nat"
type_synonym ('l,'t,'x) thread_info = "'t  ('x × 'l released_locks)"
type_synonym ('w,'t) wait_sets = "'t  'w wait_set_status"
type_synonym 't interrupts = "'t set"
type_synonym ('l,'t,'x,'m,'w) state = "('l,'t) locks × (('l,'t,'x) thread_info × 'm) × ('w,'t) wait_sets × 't interrupts"

translations
  (type) "('l, 't) locks" <= (type) "'l ⇒f ('t × nat) option"
  (type) "('l, 't, 'x) thread_info" <= (type) "'t  ('x × ('l ⇒f nat))"

(* pretty printing for state type *)
print_translation let
    fun tr'
       [Const (@{type_syntax finfun}, _) $ l1 $
        (Const (@{type_syntax option}, _) $
          (Const (@{type_syntax "prod"}, _) $ t1 $ Const (@{type_syntax nat}, _))),
        Const (@{type_syntax "prod"}, _) $
          (Const (@{type_syntax "prod"}, _) $
            (Const (@{type_syntax fun}, _) $ t2 $
              (Const (@{type_syntax option}, _) $
                (Const (@{type_syntax "prod"}, _) $ x $
                  (Const (@{type_syntax finfun}, _) $ l2 $ Const (@{type_syntax nat}, _))))) $
            m) $
          (Const (@{type_syntax prod}, _) $
            (Const (@{type_syntax fun}, _) $ t3 $ 
              (Const (@{type_syntax option}, _) $ (Const (@{type_syntax wait_set_status}, _) $ w))) $
            (Const (@{type_syntax fun}, _) $ t4 $ (Const (@{type_syntax bool}, _))))] =
      if t1 = t2 andalso t1 = t3 andalso t1 = t4 andalso l1 = l2
      then Syntax.const @{type_syntax state} $ l1 $ t1 $ x $ m $ w
      else raise Match;
  in [(@{type_syntax "prod"}, K tr')]
  end
typ "('l,'t,'x,'m,'w) state"


abbreviation no_wait_locks :: "'l ⇒f nat"
where "no_wait_locks  (K$ 0)"

lemma neq_no_wait_locks_conv:
  "ln. ln  no_wait_locks  (l. ln $ l > 0)"
by(auto simp add: expand_finfun_eq fun_eq_iff)

lemma neq_no_wait_locksE:
  fixes ln assumes "ln  no_wait_locks" obtains l where "ln $ l > 0"
using assms
by(auto simp add: neq_no_wait_locks_conv)

text ‹
  Use type variables for components instead of @{typ "('l,'t,'x,'m,'w) state"} in types for state projections
  to allow to reuse them for refined state implementations for code generation.
›

definition locks :: "('locks × ('thread_info × 'm) × 'wsets × 'interrupts)  'locks" where
  "locks lstsmws  fst lstsmws"

definition thr :: "('locks × ('thread_info × 'm) × 'wsets × 'interrupts)  'thread_info" where
  "thr lstsmws  fst (fst (snd lstsmws))"

definition shr :: "('locks × ('thread_info × 'm) × 'wsets × 'interrupts)  'm" where
  "shr lstsmws  snd (fst (snd lstsmws))"

definition wset :: "('locks × ('thread_info × 'm) × 'wsets × 'interrupts)  'wsets" where
  "wset lstsmws  fst (snd (snd lstsmws))"

definition interrupts :: "('locks × ('thread_info × 'm) × 'wsets × 'interrupts)  'interrupts" where
  "interrupts lstsmws  snd (snd (snd lstsmws))"

lemma locks_conv [simp]: "locks (ls, tsmws) = ls"
by(simp add: locks_def)

lemma thr_conv [simp]: "thr (ls, (ts, m), ws) = ts"
by(simp add: thr_def)

lemma shr_conv [simp]: "shr (ls, (ts, m), ws, is) = m"
by(simp add: shr_def)

lemma wset_conv [simp]: "wset (ls, (ts, m), ws, is) = ws"
by(simp add: wset_def)

lemma interrupts_conv [simp]: "interrupts (ls, (ts, m), ws, is) = is"
by(simp add: interrupts_def)

primrec convert_new_thread_action :: "('x  'x')  ('t,'x,'m) new_thread_action  ('t,'x','m) new_thread_action"
where
  "convert_new_thread_action f (NewThread t x m) = NewThread t (f x) m"
| "convert_new_thread_action f (ThreadExists t b) = ThreadExists t b"

lemma convert_new_thread_action_inv [simp]:
  "NewThread t x h = convert_new_thread_action f nta  (x'. nta = NewThread t x' h  x = f x')"
  "ThreadExists t b = convert_new_thread_action f nta  nta = ThreadExists t b"
  "convert_new_thread_action f nta = NewThread t x h  (x'. nta = NewThread t x' h  x = f x')"
  "convert_new_thread_action f nta = ThreadExists t b  nta = ThreadExists t b"
by(cases nta, auto)+

lemma convert_new_thread_action_eqI: 
  " t x m. nta = NewThread t x m  nta' = NewThread t (f x) m;
     t b. nta = ThreadExists t b  nta' = ThreadExists t b 
   convert_new_thread_action f nta = nta'"
apply(cases nta)
apply fastforce+
done

lemma convert_new_thread_action_compose [simp]:
  "convert_new_thread_action f (convert_new_thread_action g ta) = convert_new_thread_action (f o g) ta"
apply(cases ta)
apply(simp_all add: convert_new_thread_action_def)
done

lemma inj_convert_new_thread_action [simp]: 
  "inj (convert_new_thread_action f) = inj f"
apply(rule iffI)
 apply(rule injI)
 apply(drule_tac x="NewThread undefined x undefined" in injD)
 apply auto[2]
apply(rule injI)
apply(case_tac x)
apply(auto dest: injD)
done

lemma convert_new_thread_action_id:
  "convert_new_thread_action id = (id :: ('t, 'x, 'm) new_thread_action  ('t, 'x, 'm) new_thread_action)" (is ?thesis1)
  "convert_new_thread_action (λx. x) = (id :: ('t, 'x, 'm) new_thread_action  ('t, 'x, 'm) new_thread_action)" (is ?thesis2)
proof -
  show ?thesis1 by(rule ext)(case_tac x, simp_all)
  thus ?thesis2 by(simp add: id_def)
qed

definition convert_extTA :: "('x  'x')  ('l,'t,'x,'m,'w,'o) thread_action  ('l,'t,'x','m,'w,'o) thread_action"
where "convert_extTA f ta = (tal, map (convert_new_thread_action f) tat, snd (snd ta))"

lemma convert_extTA_simps [simp]:
  "convert_extTA f ε = ε"
  "convert_extTA f tal = tal"
  "convert_extTA f tat = map (convert_new_thread_action f) tat"
  "convert_extTA f tac = tac"
  "convert_extTA f taw = taw"
  "convert_extTA f tai = tai"
  "convert_extTA f (las, tas, was, cas, is, obs) = (las, map (convert_new_thread_action f) tas, was, cas, is, obs)"
apply(simp_all add: convert_extTA_def)
apply(cases ta, simp)+
done

lemma convert_extTA_eq_conv:
  "convert_extTA f ta = ta' 
   tal = ta'l  tac = ta'c  taw = ta'w  tao = ta'o  tai = ta'i  length tat = length ta't  
   (n < length tat. convert_new_thread_action f (tat ! n) = ta't ! n)"
apply(cases ta, cases ta')
apply(auto simp add: convert_extTA_def map_eq_all_nth_conv)
done

lemma convert_extTA_compose [simp]:
  "convert_extTA f (convert_extTA g ta) = convert_extTA (f o g) ta"
by(simp add: convert_extTA_def)

lemma obs_a_convert_extTA [simp]: "obs_a (convert_extTA f ta) = obs_a ta"
by(cases ta) simp

text ‹Actions for thread start/finish›

datatype 'o action =
    NormalAction 'o
  | InitialThreadAction
  | ThreadFinishAction

instance action :: (type) obs_action
proof qed

definition convert_obs_initial :: "('l,'t,'x,'m,'w,'o) thread_action  ('l,'t,'x,'m,'w,'o action) thread_action"
where 
  "convert_obs_initial ta = (tal, tat, tac, taw, tai, map NormalAction tao)"

lemma inj_NormalAction [simp]: "inj NormalAction"
by(rule injI) auto

lemma convert_obs_initial_inject [simp]:
  "convert_obs_initial ta = convert_obs_initial ta'  ta = ta'"
by(cases ta)(cases ta', auto simp add: convert_obs_initial_def)

lemma convert_obs_initial_empty_TA [simp]:
  "convert_obs_initial ε = ε"
by(simp add: convert_obs_initial_def)

lemma convert_obs_initial_eq_empty_TA [simp]:
  "convert_obs_initial ta = ε  ta = ε"
  "ε = convert_obs_initial ta  ta = ε"
by(case_tac [!] ta)(auto simp add: convert_obs_initial_def)

lemma convert_obs_initial_simps [simp]:
  "convert_obs_initial tao = map NormalAction tao"
  "convert_obs_initial tal = tal"
  "convert_obs_initial tat = tat"
  "convert_obs_initial tac = tac"
  "convert_obs_initial taw = taw"
  "convert_obs_initial tai = tai"
by(simp_all add: convert_obs_initial_def)

type_synonym
  ('l,'t,'x,'m,'w,'o) semantics =
    "'t  'x × 'm  ('l,'t,'x,'m,'w,'o) thread_action  'x × 'm  bool"

(* pretty printing for semantics *)
print_translation let
    fun tr'
       [t4,
        Const (@{type_syntax fun}, _) $
          (Const (@{type_syntax "prod"}, _) $ x1 $ m1) $
          (Const (@{type_syntax fun}, _) $
            (Const (@{type_syntax "prod"}, _) $
              (Const (@{type_syntax finfun}, _) $ l $
                (Const (@{type_syntax list}, _) $ Const (@{type_syntax lock_action}, _))) $
              (Const (@{type_syntax "prod"}, _) $
                (Const (@{type_syntax list}, _) $ (Const (@{type_syntax new_thread_action}, _) $ t1 $ x2 $ m2)) $
                (Const (@{type_syntax "prod"}, _) $
                  (Const (@{type_syntax list}, _) $ (Const (@{type_syntax conditional_action}, _) $ t2)) $
                  (Const (@{type_syntax "prod"}, _) $
                    (Const (@{type_syntax list}, _) $ (Const (@{type_syntax wait_set_action}, _) $ t3 $ w)) $ 
                    (Const (@{type_syntax prod}, _) $
                       (Const (@{type_syntax list}, _) $ (Const (@{type_syntax interrupt_action}, _) $ t5)) $
                       (Const (@{type_syntax list}, _) $ o1)))))) $
            (Const (@{type_syntax fun}, _) $ (Const (@{type_syntax "prod"}, _) $ x3 $ m3) $
              Const (@{type_syntax bool}, _)))] =
      if x1 = x2 andalso x1 = x3 andalso m1 = m2 andalso m1 = m3 
        andalso t1 = t2 andalso t2 = t3 andalso t3 = t4 andalso t4 = t5
      then Syntax.const @{type_syntax semantics} $ l $ t1 $ x1 $ m1 $ w $ o1
      else raise Match;
  in [(@{type_syntax fun}, K tr')]
  end
typ "('l,'t,'x,'m,'w,'o) semantics"

end

Theory FWLock

(*  Title:      JinjaThreads/Framework/FWLock.thy
    Author:     Andreas Lochbihler
*)

section ‹All about a managing a single lock›

theory FWLock
imports
  FWState
begin

fun has_locks :: "'t lock  't  nat" where
  "has_locks None t = 0"
| "has_locks (t', n) t = (if t = t' then Suc n else 0)"

lemma has_locks_iff: 
  "has_locks l t = n 
  (l = None  n = 0)  
  (n'. l = (t, n')  Suc n' = n)  (t' n'. l = (t', n')  t'  t  n = 0)"
by(cases l, auto)

lemma has_locksE:
  " has_locks l t = n;
      l = None; n = 0   P;
     n'.  l = (t, n'); Suc n' = n   P;
     t' n'.  l = (t', n'); t'  t; n = 0   P 
   P"
by(auto simp add: has_locks_iff split: if_split_asm prod.split_asm)


inductive may_lock :: "'t lock  't  bool" where
  "may_lock None t"
| "may_lock (t, n) t"

lemma may_lock_iff [code]:
  "may_lock l t = (case l of None  True | (t', n)  t = t')"
by(auto intro: may_lock.intros elim: may_lock.cases)

lemma may_lockI:
  "l = None  (n. l = (t, n))  may_lock l t"
by(cases l, auto intro: may_lock.intros)

lemma may_lockE [consumes 1, case_names None Locked]:
  " may_lock l t; l = None  P; n. l = (t, n)   P   P"
by(auto elim: may_lock.cases)

lemma may_lock_may_lock_t_eq:
  " may_lock l t; may_lock l t'   (l = None)  (t = t')"
by(auto elim!: may_lockE)

abbreviation has_lock :: "'t lock  't  bool"
where "has_lock l t  0 < has_locks l t"

lemma has_locks_Suc_has_lock:
  "has_locks l t = Suc n  has_lock l t"
by(auto)

lemmas has_lock_has_locks_Suc = gr0_implies_Suc[where n = "has_locks l t"] for l t

lemma has_lock_has_locks_conv:
  "has_lock l t  (n. has_locks l t = (Suc n))"
by(auto intro: has_locks_Suc_has_lock has_lock_has_locks_Suc)

lemma has_lock_may_lock:
  "has_lock l t  may_lock l t"
by(cases l, auto intro: may_lockI)

lemma has_lock_may_lock_t_eq:
  " has_lock l t; may_lock l t'   t = t'"
by(auto elim!: may_lockE split: if_split_asm)

lemma has_locks_has_locks_t_eq: 
  "has_locks l t = Suc n; has_locks l t' = Suc n'  t = t'"
by(auto elim: has_locksE)

lemma has_lock_has_lock_t_eq:
  " has_lock l t; has_lock l t'   t = t'"
unfolding has_lock_has_locks_conv
by(auto intro: has_locks_has_locks_t_eq)

lemma not_may_lock_conv:
  "¬ may_lock l t  (t'. t'  t  has_lock l t')"
by(cases l, auto intro: may_lock.intros elim: may_lockE)



(* State update functions for locking *)

fun lock_lock :: "'t lock  't  't lock" where
  "lock_lock None t = (t, 0)"
| "lock_lock (t', n) t = (t', Suc n)"

fun unlock_lock :: "'t lock  't lock" where
  "unlock_lock None = None"
| "unlock_lock (t, n) = (case n of 0  None | Suc n'  (t, n'))"

fun release_all :: "'t lock  't  't lock" where
  "release_all None t = None"
| "release_all (t', n) t = (if t = t' then None else (t', n))"

fun acquire_locks :: "'t lock  't  nat  't lock" where
  "acquire_locks L t 0 = L"
| "acquire_locks L t (Suc m) = acquire_locks (lock_lock L t) t m"

lemma acquire_locks_conv:
  "acquire_locks L t n = (case L of None  (case n of 0  None | Suc m  (t, m)) | (t', m)  (t', n + m))"
by(induct n arbitrary: L)(auto)

lemma lock_lock_ls_Some:
  "t' n. lock_lock l t = (t', n)"
by(cases l, auto)

lemma unlock_lock_SomeD:
  "unlock_lock l = (t', n)  l = (t', Suc n)"
by(cases l, auto split: nat.split_asm)

lemma has_locks_Suc_lock_lock_has_locks_Suc_Suc:
  "has_locks l t = Suc n  has_locks (lock_lock l t) t = Suc (Suc n)"
by(auto elim!: has_locksE)

lemma has_locks_lock_lock_conv [simp]:
  "may_lock l t  has_locks (lock_lock l t) t = Suc (has_locks l t)"
by(auto elim: may_lockE)

lemma has_locks_release_all_conv [simp]:
  "has_locks (release_all l t) t = 0"
by(cases l, auto split: if_split_asm)

lemma may_lock_lock_lock_conv [simp]: "may_lock (lock_lock l t) t = may_lock l t"
by(cases l, auto elim!: may_lock.cases intro: may_lock.intros)

lemma has_locks_acquire_locks_conv [simp]:
  "may_lock l t  has_locks (acquire_locks l t n) t = has_locks l t + n"
by(induct n arbitrary: l, auto)

lemma may_lock_unlock_lock_conv [simp]:
  "has_lock l t  may_lock (unlock_lock l) t = may_lock l t"
by(cases l)(auto split: if_split_asm nat.splits elim!: may_lock.cases intro: may_lock.intros)

lemma may_lock_release_all_conv [simp]:
  "may_lock (release_all l t) t = may_lock l t"
by(cases l, auto split: if_split_asm intro!: may_lockI elim: may_lockE)

lemma may_lock_t_may_lock_unlock_lock_t: 
  "may_lock l t  may_lock (unlock_lock l) t"
by(auto intro: may_lock.intros elim!: may_lockE split: nat.split)


lemma may_lock_has_locks_lock_lock_0: 
  "may_lock l t'; t  t'  has_locks (lock_lock l t') t = 0"
by(auto elim!: may_lock.cases)

lemma has_locks_unlock_lock_conv [simp]:
  "has_lock l t  has_locks (unlock_lock l) t = has_locks l t - 1"
by(cases l)(auto split: nat.split)

lemma has_lock_lock_lock_unlock_lock_id [simp]:
  "has_lock l t  lock_lock (unlock_lock l) t = l"
by(cases l)(auto split: if_split_asm nat.split)

lemma may_lock_unlock_lock_lock_lock_id [simp]:
  "may_lock l t  unlock_lock (lock_lock l t) = l"
by(cases l) auto


lemma may_lock_has_locks_0:
  " may_lock l t; t  t'   has_locks l t' = 0"
by(auto elim!: may_lockE)


fun upd_lock :: "'t lock  't  lock_action  't lock"
where
  "upd_lock l t Lock = lock_lock l t"
| "upd_lock l t Unlock = unlock_lock l"
| "upd_lock l t UnlockFail = l"
| "upd_lock l t ReleaseAquire = release_all l t"

fun upd_locks :: "'t lock  't  lock_action list  't lock"
where
  "upd_locks l t [] = l"
| "upd_locks l t (L # Ls) = upd_locks (upd_lock l t L) t Ls"

lemma upd_locks_append [simp]:
  "upd_locks l t (Ls @ Ls') = upd_locks (upd_locks l t Ls) t Ls'"
by(induct Ls arbitrary: l, auto)

lemma upd_lock_Some_thread_idD:
  assumes ul: "upd_lock l t L = (t', n)"
  and tt': "t  t'"
  shows "n. l = (t', n)"
proof(cases L)
  case Lock
  with ul tt' show ?thesis
    by(cases l, auto)
next
  case Unlock
  with ul tt' show ?thesis
    by(auto dest: unlock_lock_SomeD)
next
  case UnlockFail
  with ul show ?thesis by(simp)
next
  case ReleaseAcquire
  with ul show ?thesis
    by(cases l, auto split: if_split_asm)
qed


lemma has_lock_upd_lock_implies_has_lock:
  " has_lock (upd_lock l t L) t'; t  t'   has_lock l t'"
by(cases l L rule: option.exhaust[case_product lock_action.exhaust])(auto split: if_split_asm nat.split_asm)

lemma has_lock_upd_locks_implies_has_lock:
  " has_lock (upd_locks l t Ls) t'; t  t'   has_lock l t'"
by(induct l t Ls rule: upd_locks.induct)(auto intro: has_lock_upd_lock_implies_has_lock)

(* Preconditions for lock actions *)

fun lock_action_ok :: "'t lock  't  lock_action  bool" where
  "lock_action_ok l t Lock = may_lock l t"
| "lock_action_ok l t Unlock = has_lock l t"
| "lock_action_ok l t UnlockFail = (¬ has_lock l t)"
| "lock_action_ok l t ReleaseAcquire = True"

fun lock_actions_ok :: "'t lock  't  lock_action list  bool" where
  "lock_actions_ok l t [] = True"
| "lock_actions_ok l t (L # Ls) = (lock_action_ok l t L  lock_actions_ok (upd_lock l t L) t Ls)"

lemma lock_actions_ok_append [simp]:
  "lock_actions_ok l t (Ls @ Ls')  lock_actions_ok l t Ls  lock_actions_ok (upd_locks l t Ls) t Ls'"
by(induct Ls arbitrary: l) auto

lemma not_lock_action_okE [consumes 1, case_names Lock Unlock UnlockFail]:
  " ¬ lock_action_ok l t L;
      L = Lock; ¬ may_lock l t   Q;
      L = Unlock; ¬ has_lock l t   Q;
      L = UnlockFail; has_lock l t   Q
   Q"
by(cases L) auto

lemma may_lock_upd_lock_conv [simp]:
  "lock_action_ok l t L  may_lock (upd_lock l t L) t = may_lock l t"
by(cases L) auto

lemma may_lock_upd_locks_conv [simp]:
  "lock_actions_ok l t Ls  may_lock (upd_locks l t Ls) t = may_lock l t"
by(induct l t Ls rule: upd_locks.induct) simp_all

lemma lock_actions_ok_Lock_may_lock:
  " lock_actions_ok l t Ls; Lock  set Ls   may_lock l t"
by(induct l t Ls rule: lock_actions_ok.induct) auto

lemma has_locks_lock_lock_conv' [simp]:
  " may_lock l t'; t  t'   has_locks (lock_lock l t') t = has_locks l t"
by(cases l)(auto elim: may_lock.cases)

lemma has_locks_unlock_lock_conv' [simp]:
  " has_lock l t'; t  t'   has_locks (unlock_lock l) t = has_locks l t"
by(cases l)(auto split: if_split_asm nat.split)

lemma has_locks_release_all_conv' [simp]:
  "t  t'  has_locks (release_all l t') t = has_locks l t"
by(cases l) auto

lemma has_locks_acquire_locks_conv' [simp]:
  " may_lock l t; t  t'   has_locks (acquire_locks l t n) t' = has_locks l t'"
by(induct l t n rule: acquire_locks.induct) simp_all

lemma lock_action_ok_has_locks_upd_lock_eq_has_locks [simp]:
  " lock_action_ok l t' L; t  t'   has_locks (upd_lock l t' L) t = has_locks l t"
by(cases L) auto

lemma lock_actions_ok_has_locks_upd_locks_eq_has_locks [simp]:
  " lock_actions_ok l t' Ls; t  t'   has_locks (upd_locks l t' Ls) t = has_locks l t"
by(induct l t' Ls rule: upd_locks.induct) simp_all

lemma has_lock_acquire_locks_implies_has_lock:
  " has_lock (acquire_locks l t n) t'; t  t'   has_lock l t'"
 unfolding acquire_locks_conv
 by(cases n)(auto split: if_split_asm)

lemma has_lock_has_lock_acquire_locks:
  "has_lock l T  has_lock (acquire_locks l t n) T"
  unfolding acquire_locks_conv
  by(auto)


fun lock_actions_ok' :: "'t lock  't  lock_action list  bool" where
  "lock_actions_ok' l t [] = True"
| "lock_actions_ok' l t (L#Ls) = ((L = Lock  ¬ may_lock l t) 
                                  lock_action_ok l t L  lock_actions_ok' (upd_lock l t L) t Ls)"

lemma lock_actions_ok'_iff:
  "lock_actions_ok' l t las  
   lock_actions_ok l t las  (xs ys. las = xs @ Lock # ys  lock_actions_ok l t xs  ¬ may_lock (upd_locks l t xs) t)"
proof(induct l t las rule: lock_actions_ok.induct)
  case (2 L t LA LAS)
  show ?case
  proof(cases "LA = Lock  ¬ may_lock L t")
    case True
    hence "(ys. Lock # LAS = [] @ Lock # ys)  lock_actions_ok L t []  ¬ may_lock (upd_locks L t []) t"
      by(simp)
    with True show ?thesis by(simp (no_asm))(blast)
  next
    case False
    with 2 show ?thesis
      by(fastforce simp add: Cons_eq_append_conv elim: allE[where x="LA # xs" for xs])
  qed
qed simp

lemma lock_actions_ok'E[consumes 1, case_names ok Lock]:
  " lock_actions_ok' l t las;
     lock_actions_ok l t las  P;
     xs ys.  las = xs @ Lock # ys; lock_actions_ok l t xs; ¬ may_lock (upd_locks l t xs) t   P  
   P"
by(auto simp add: lock_actions_ok'_iff)

end

Theory FWLocking

(*  Title:      JinjaThreads/Framework/FWLocking.thy
    Author:     Andreas Lochbihler
*)

section ‹Semantics of the thread actions for locking›

theory FWLocking
imports
  FWLock
begin

definition redT_updLs :: "('l,'t) locks  't  'l lock_actions  ('l,'t) locks" where
  "redT_updLs ls t las  (λ(l, la). upd_locks l t la) ∘$ (($ls, las$))"

lemma redT_updLs_iff [simp]: "redT_updLs ls t las $ l = upd_locks (ls $ l) t (las $ l)"
by(simp add: redT_updLs_def)

lemma upd_locks_empty_conv [simp]: "(λ(l, las). upd_locks l t las) ∘$ ($ls, K$ []$) = ls"
by(auto intro: finfun_ext)

lemma redT_updLs_Some_thread_idD:
  " has_lock (redT_updLs ls t las $ l) t'; t  t'   has_lock (ls $ l) t'"
by(auto simp add: redT_updLs_def intro: has_lock_upd_locks_implies_has_lock)

definition acquire_all :: "('l, 't) locks  't  ('l ⇒f nat)  ('l, 't) locks"
where "ln. acquire_all ls t ln  (λ(l, la). acquire_locks l t la) ∘$ (($ls, ln$))"

lemma acquire_all_iff [simp]: 
  "ln. acquire_all ls t ln $ l = acquire_locks (ls $ l) t (ln $ l)"
by(simp add: acquire_all_def)


definition lock_ok_las :: "('l,'t) locks  't  'l lock_actions  bool" where
  "lock_ok_las ls t las  l. lock_actions_ok (ls $ l) t (las $ l)"

lemma lock_ok_lasI [intro]:
  "(l. lock_actions_ok (ls $ l) t (las $ l))  lock_ok_las ls t las"
by(simp add: lock_ok_las_def)

lemma lock_ok_lasE:
  " lock_ok_las ls t las; (l. lock_actions_ok (ls $ l) t (las $ l))  Q   Q"
by(simp add: lock_ok_las_def)

lemma lock_ok_lasD:
  "lock_ok_las ls t las  lock_actions_ok (ls $ l) t (las $ l)"
by(simp add: lock_ok_las_def)

lemma lock_ok_las_code [code]:
  "lock_ok_las ls t las = finfun_All ((λ(l, la). lock_actions_ok l t la) ∘$ ($ls, las$))"
by(simp add: lock_ok_las_def finfun_All_All o_def)

lemma lock_ok_las_may_lock:
  " lock_ok_las ls t las; Lock  set (las $ l)   may_lock (ls $ l) t"
by(erule lock_ok_lasE)(rule lock_actions_ok_Lock_may_lock)

lemma redT_updLs_may_lock [simp]:
  "lock_ok_las ls t las  may_lock (redT_updLs ls t las $ l) t = may_lock (ls $ l) t"
by(auto dest!: lock_ok_lasD[where l=l])

lemma redT_updLs_has_locks [simp]:
  " lock_ok_las ls t' las; t  t'   has_locks (redT_updLs ls t' las $ l) t = has_locks (ls $ l) t"
by(auto dest!: lock_ok_lasD[where l=l])


definition may_acquire_all :: "('l, 't) locks  't  ('l ⇒f nat)  bool"
where "ln. may_acquire_all ls t ln  l. ln $ l > 0  may_lock (ls $ l) t"

lemma may_acquire_allI [intro]:
  "ln. (l. ln $ l > 0  may_lock (ls $ l) t)  may_acquire_all ls t ln"
by(simp add: may_acquire_all_def)

lemma may_acquire_allE:
  "ln.  may_acquire_all ls t ln; l. ln $ l > 0  may_lock (ls $ l) t  P   P"
by(auto simp add: may_acquire_all_def)

lemma may_acquire_allD [dest]:
  "ln.  may_acquire_all ls t ln; ln $ l > 0   may_lock (ls $ l) t"
by(auto simp add: may_acquire_all_def)

lemma may_acquire_all_has_locks_acquire_locks [simp]:
  fixes ln
  shows " may_acquire_all ls t ln; t  t'   has_locks (acquire_locks (ls $ l) t (ln $ l)) t' = has_locks (ls $ l) t'"
by(cases "ln $ l > 0")(auto dest: may_acquire_allD)

lemma may_acquire_all_code [code]:
  "ln. may_acquire_all ls t ln  finfun_All ((λ(lock, n). n > 0  may_lock lock t) ∘$ ($ls, ln$))"
by(auto simp add: may_acquire_all_def finfun_All_All o_def)

definition collect_locks :: "'l lock_actions  'l set" where
  "collect_locks las = {l. Lock  set (las $ l)}"

lemma collect_locksI:
  "Lock  set (las $ l)  l  collect_locks las"
by(simp add: collect_locks_def)

lemma collect_locksE:
  " l  collect_locks las; Lock  set (las $ l)  P   P"
by(simp add: collect_locks_def)

lemma collect_locksD:
  "l  collect_locks las  Lock  set (las $ l)"
by(simp add: collect_locks_def)


fun must_acquire_lock :: "lock_action list  bool" where
  "must_acquire_lock [] = False"
| "must_acquire_lock (Lock # las) = True"
| "must_acquire_lock (Unlock # las) = False"
| "must_acquire_lock (_ # las) = must_acquire_lock las"

lemma must_acquire_lock_append:
  "must_acquire_lock (xs @ ys)  (if Lock  set xs  Unlock  set xs then must_acquire_lock xs else must_acquire_lock ys)"
proof(induct xs)
  case Nil thus ?case by simp
next
  case (Cons L Ls)
  thus ?case by (cases L, simp_all)
qed

lemma must_acquire_lock_contains_lock:
  "must_acquire_lock las  Lock  set las"
proof(induct las)
  case (Cons l las) thus ?case by(cases l) auto
qed simp

lemma must_acquire_lock_conv:
  "must_acquire_lock las = (case (filter (λL. L = Lock  L = Unlock) las) of []  False | L # Ls  L = Lock)"
proof(induct las)
  case Nil thus ?case by simp
next
  case (Cons LA LAS) thus ?case
    by(cases LA, auto split: list.split_asm)
qed


definition collect_locks' :: "'l lock_actions  'l set" where
  "collect_locks' las  {l. must_acquire_lock (las $ l)}"

lemma collect_locks'I:
  "must_acquire_lock (las $ l)  l  collect_locks' las"
by(simp add: collect_locks'_def)

lemma collect_locks'E:
  " l  collect_locks' las; must_acquire_lock (las $ l)  P   P"
by(simp add: collect_locks'_def)

lemma collect_locks'_subset_collect_locks:
  "collect_locks' las  collect_locks las"
by(auto simp add: collect_locks'_def collect_locks_def intro: must_acquire_lock_contains_lock)

definition lock_ok_las' :: "('l,'t) locks  't  'l lock_actions  bool" where
  "lock_ok_las' ls t las  l. lock_actions_ok' (ls $ l) t (las $ l)"

lemma lock_ok_las'I: "(l. lock_actions_ok' (ls $ l) t (las $ l))  lock_ok_las' ls t las"
by(simp add: lock_ok_las'_def)

lemma lock_ok_las'D: "lock_ok_las' ls t las  lock_actions_ok' (ls $ l) t (las $ l)"
by(simp add: lock_ok_las'_def)

lemma not_lock_ok_las'_conv:
  "¬ lock_ok_las' ls t las  (l. ¬ lock_actions_ok' (ls $ l) t (las $ l))"
by(simp add: lock_ok_las'_def)

lemma lock_ok_las'_code:
    "lock_ok_las' ls t las = finfun_All ((λ(l, la). lock_actions_ok' l t la) ∘$ ($ls, las$))"
by(simp add: lock_ok_las'_def finfun_All_All o_def)


lemma lock_ok_las'_collect_locks'_may_lock:
  assumes lot': "lock_ok_las' ls t las"
  and mayl: "l  collect_locks' las. may_lock (ls $ l) t"
  and l: "l  collect_locks las"
  shows "may_lock (ls $ l) t"
proof(cases "l  collect_locks' las")
  case True thus ?thesis using mayl by auto
next
  case False
  hence nmal: "¬ must_acquire_lock (las $ l)"
    by(auto intro: collect_locks'I)
  from l have locklasl: "Lock  set (las $ l)"
    by(rule collect_locksD)
  then obtain ys zs
    where las: "las $ l = ys @ Lock # zs"
    and notin: "Lock  set ys"
    by(auto dest: split_list_first)
  from lot' have "lock_actions_ok' (ls $ l) t (las $ l)"
    by(auto simp add: lock_ok_las'_def)
  thus ?thesis
  proof(induct rule: lock_actions_ok'E)
    case ok
    with locklasl show ?thesis
      by -(rule lock_actions_ok_Lock_may_lock)
  next
    case (Lock YS ZS)
    note LAS = las $ l = YS @ Lock # ZS
    note lao = ‹lock_actions_ok (ls $ l) t YS
    note nml = ¬ may_lock (upd_locks (ls $ l) t YS) t
    from LAS las nmal notin have "Unlock  set YS"
      by -(erule contrapos_np, auto simp add: must_acquire_lock_append append_eq_append_conv2 append_eq_Cons_conv)
    then obtain ys' zs'
      where YS: "YS = ys' @ Unlock # zs'"
      and unlock: "Unlock  set ys'"
      by(auto dest: split_list_first)
    from YS las LAS lao have lao': "lock_actions_ok (ls $ l) t (ys' @ [Unlock])" by(auto)
    hence "has_lock (upd_locks (ls $ l) t ys') t" by simp
    hence "may_lock (upd_locks (ls $ l) t ys') t"
      by(rule has_lock_may_lock)
    moreover from lao' have "lock_actions_ok (ls $ l) t ys'" by simp
    ultimately show ?thesis by simp
  qed
qed

lemma lock_actions_ok'_must_acquire_lock_lock_actions_ok:
  " lock_actions_ok' l t Ls; must_acquire_lock Ls  may_lock l t  lock_actions_ok l t Ls"
proof(induct l t Ls rule: lock_actions_ok.induct)
  case 1 thus ?case by simp
next
  case (2 l t L LS) thus ?case
  proof(cases "L = Lock  L = Unlock")
    case True
    with 2 show ?thesis by(auto simp add: lock_actions_ok'_iff Cons_eq_append_conv intro: has_lock_may_lock)
  qed(cases L, auto)
qed

lemma lock_ok_las'_collect_locks_lock_ok_las:
  assumes lol': "lock_ok_las' ls t las"
  and clml: "l. l  collect_locks las  may_lock (ls $ l) t"
  shows "lock_ok_las ls t las"
proof(rule lock_ok_lasI)
  fix l
  from lol' have "lock_actions_ok' (ls $ l) t (las $ l)" by(rule lock_ok_las'D)
  thus "lock_actions_ok (ls $ l) t (las $ l)"
  proof(rule lock_actions_ok'_must_acquire_lock_lock_actions_ok[OF _ impI])
    assume mal: "must_acquire_lock (las $ l)"
    thus "may_lock (ls $ l) t"
      by(auto intro!: clml collect_locksI elim: must_acquire_lock_contains_lock )
  qed
qed

lemma lock_ok_las'_into_lock_on_las:
  "lock_ok_las' ls t las; l. l  collect_locks' las  may_lock (ls $ l) t  lock_ok_las ls t las"
by (metis lock_ok_las'_collect_locks'_may_lock lock_ok_las'_collect_locks_lock_ok_las)

end

Theory FWThread

(*  Title:      JinjaThreads/Framework/FWThread.thy
    Author:     Andreas Lochbihler
*)

section ‹Semantics of the thread actions for thread creation›

theory FWThread
imports
  FWState
begin

text‹Abstractions for thread ids›

context
  notes [[inductive_internals]]
begin

inductive free_thread_id :: "('l,'t,'x) thread_info  't  bool"
for ts :: "('l,'t,'x) thread_info" and t :: 't
where "ts t = None  free_thread_id ts t"

declare free_thread_id.cases [elim]

end

lemma free_thread_id_iff: "free_thread_id ts t = (ts t = None)"
by(auto elim: free_thread_id.cases intro: free_thread_id.intros)

text‹Update functions for the multithreaded state›

fun redT_updT :: "('l,'t,'x) thread_info  ('t,'x,'m) new_thread_action  ('l,'t,'x) thread_info"
where
  "redT_updT ts (NewThread t' x m) = ts(t'  (x, no_wait_locks))"
| "redT_updT ts _ = ts"

fun redT_updTs :: "('l,'t,'x) thread_info  ('t,'x,'m) new_thread_action list  ('l,'t,'x) thread_info"
where
  "redT_updTs ts [] = ts"
| "redT_updTs ts (ta#tas) = redT_updTs (redT_updT ts ta) tas"

lemma redT_updTs_append [simp]:
  "redT_updTs ts (tas @ tas') = redT_updTs (redT_updTs ts tas) tas'"
by(induct ts tas rule: redT_updTs.induct) auto

lemma redT_updT_None: 
  "redT_updT ts ta t = None  ts t = None"
by(cases ta)(auto split: if_splits)

lemma redT_updTs_None: "redT_updTs ts tas t = None  ts t = None"
by(induct ts tas rule: redT_updTs.induct)(auto intro: redT_updT_None)

lemma redT_updT_Some1:
  "ts t = xw  xw. redT_updT ts ta t = xw"
by(cases ta) auto

lemma redT_updTs_Some1:
  "ts t = xw  xw. redT_updTs ts tas t = xw"
unfolding not_None_eq[symmetric]
by(induct ts tas arbitrary: xw rule: redT_updTs.induct)(simp_all del: split_paired_Ex, blast dest: redT_updT_Some1)

lemma redT_updT_finite_dom_inv:
  "finite (dom (redT_updT ts ta)) = finite (dom ts)"
by(cases ta) auto

lemma redT_updTs_finite_dom_inv:
  "finite (dom (redT_updTs ts tas)) = finite (dom ts)"
by(induct ts tas rule: redT_updTs.induct)(simp_all add: redT_updT_finite_dom_inv)

text‹Preconditions for thread creation actions›

text‹These primed versions are for checking preconditions only. They allow the thread actions to have a type for thread-local information that is different than the thread info state itself.›

fun redT_updT' :: "('l,'t,'x) thread_info  ('t,'x','m) new_thread_action  ('l,'t,'x) thread_info"
where
  "redT_updT' ts (NewThread t' x m) = ts(t'  (undefined, no_wait_locks))"
| "redT_updT' ts _ = ts"

fun redT_updTs' :: "('l,'t,'x) thread_info  ('t,'x','m) new_thread_action list  ('l,'t,'x) thread_info"
where
  "redT_updTs' ts [] = ts"
| "redT_updTs' ts (ta#tas) = redT_updTs' (redT_updT' ts ta) tas"

lemma redT_updT'_None: 
  "redT_updT' ts ta t = None  ts t = None"
by(cases ta)(auto split: if_splits)

primrec thread_ok :: "('l,'t,'x) thread_info  ('t,'x','m) new_thread_action  bool"
where
  "thread_ok ts (NewThread t x m) = free_thread_id ts t"
| "thread_ok ts (ThreadExists t b) = (b  free_thread_id ts t)"

fun thread_oks :: "('l,'t,'x) thread_info  ('t,'x','m) new_thread_action list  bool"
where
  "thread_oks ts [] = True"
| "thread_oks ts (ta#tas) = (thread_ok ts ta  thread_oks (redT_updT' ts ta) tas)"

lemma thread_ok_ts_change:
  "(t. ts t = None  ts' t = None)  thread_ok ts ta  thread_ok ts' ta"
by(cases ta)(auto simp add: free_thread_id_iff)

lemma thread_oks_ts_change:
  "(t. ts t = None  ts' t = None)  thread_oks ts tas  thread_oks ts' tas"
proof(induct tas arbitrary: ts ts')
  case Nil thus ?case by simp
next
  case (Cons ta tas ts ts')
  note IH = ts ts'. (t. (ts t = None) = (ts' t = None))  thread_oks ts tas = thread_oks ts' tas
  note eq = t. (ts t = None) = (ts' t = None)
  from eq have "thread_ok ts ta  thread_ok ts' ta" by(rule thread_ok_ts_change)
  moreover from eq have "t. (redT_updT' ts ta t = None) = (redT_updT' ts' ta t = None)"
    by(cases ta)(auto)
  hence "thread_oks (redT_updT' ts ta) tas = thread_oks (redT_updT' ts' ta) tas" by(rule IH)
  ultimately show ?case by simp
qed

lemma redT_updT'_eq_None_conv: 
  "(t. ts t = None  ts' t = None)  redT_updT' ts ta t = None  redT_updT ts' ta t = None"
by(cases ta) simp_all

lemma redT_updTs'_eq_None_conv:
  "(t. ts t = None  ts' t = None)  redT_updTs' ts tas t = None  redT_updTs ts' tas t = None"
apply(induct tas arbitrary: ts ts')
apply simp_all
apply(blast intro: redT_updT'_eq_None_conv del: iffI)
done

lemma thread_oks_redT_updT_conv [simp]:
  "thread_oks (redT_updT' ts ta) tas = thread_oks (redT_updT ts ta) tas"
by(rule thread_oks_ts_change)(rule redT_updT'_eq_None_conv refl)+

lemma thread_oks_append [simp]:
  "thread_oks ts (tas @ tas') = (thread_oks ts tas  thread_oks (redT_updTs' ts tas) tas')"
by(induct tas arbitrary: ts, auto)

lemma thread_oks_redT_updTs_conv [simp]:
  "thread_oks (redT_updTs' ts ta) tas = thread_oks (redT_updTs ts ta) tas"
by(rule thread_oks_ts_change)(rule redT_updTs'_eq_None_conv refl)+


lemma redT_updT_Some:
  " ts t = xw; thread_ok ts ta   redT_updT ts ta t = xw"
by(cases ta) auto

lemma redT_updTs_Some:
  " ts t = xw; thread_oks ts tas   redT_updTs ts tas t = xw"
by(induct ts tas rule: redT_updTs.induct)(auto intro: redT_updT_Some)

lemma redT_updT'_Some:
  " ts t = xw; thread_ok ts ta   redT_updT' ts ta t = xw"
by(cases ta) auto

lemma redT_updTs'_Some:
  " ts t = xw; thread_oks ts tas   redT_updTs' ts tas t = xw"
by(induct ts tas rule: redT_updTs'.induct)(auto intro: redT_updT'_Some)


lemma thread_ok_new_thread:
  "thread_ok ts (NewThread t m' x)  ts t = None"
by(auto)

lemma thread_oks_new_thread:
  " thread_oks ts tas; NewThread t x m  set tas   ts t = None"
by(induct ts tas rule: thread_oks.induct)(auto intro: redT_updT'_None)


lemma redT_updT_new_thread_ts:
  "thread_ok ts (NewThread t x m)  redT_updT ts (NewThread t x m) t = (x, no_wait_locks)"
by(simp)

lemma redT_updTs_new_thread_ts:
  " thread_oks ts tas; NewThread t x m  set tas   redT_updTs ts tas t = (x, no_wait_locks)"
by(induct ts tas rule: redT_updTs.induct)(auto intro: redT_updTs_Some)


lemma redT_updT_new_thread:
  " redT_updT ts ta t = (x, w); thread_ok ts ta; ts t = None   m. ta = NewThread t x m  w = no_wait_locks"
by(cases ta)(auto split: if_split_asm)

lemma redT_updTs_new_thread:
  " redT_updTs ts tas t = (x, w); thread_oks ts tas; ts t = None  
   m .NewThread t x m  set tas  w = no_wait_locks"
proof(induct tas arbitrary: ts)
  case Nil thus ?case by simp
next
  case (Cons TA TAS TS)
  note IH = ts. redT_updTs ts TAS t = (x, w); thread_oks ts TAS; ts t = None  m. NewThread t x m  set TAS  w = no_wait_locks›
  note es't = ‹redT_updTs TS (TA # TAS) t = (x, w)
  note cct = ‹thread_oks TS (TA # TAS)
  hence cctta: "thread_ok TS TA" and ccts: "thread_oks (redT_updT TS TA) TAS" by auto
  note est = TS t = None›
  { fix X W
    assume rest: "redT_updT TS TA t = (X, W)"
    then obtain m where "TA = NewThread t X m  W = no_wait_locks" using cctta est
      by (auto dest!: redT_updT_new_thread)
    then obtain "TA = NewThread t X m" "W = no_wait_locks" ..
    moreover from rest ccts
    have "redT_updTs TS (TA # TAS) t = (X, W)" 
      by(auto intro:redT_updTs_Some)
    with es't have "X = x" "W = w" by auto
    ultimately have ?case by auto }
  moreover
  { assume rest: "redT_updT TS TA t = None"
    hence "m. TA  NewThread t x m" using est cct
      by(clarsimp)
    with rest ccts es't have ?case by(auto dest: IH) }
  ultimately show ?case by(cases "redT_updT TS TA t", auto)
qed

lemma redT_updT_upd:
  " ts t = xw; thread_ok ts ta   redT_updT ts ta(t  xw') = redT_updT (ts(t  xw')) ta"
by(cases ta)(fastforce intro: fun_upd_twist)+

lemma redT_updTs_upd:
  " ts t = xw; thread_oks ts tas   redT_updTs ts tas(t  xw') = redT_updTs (ts(t  xw')) tas"
by(induct ts tas rule: redT_updTs.induct)(auto simp del: fun_upd_apply simp add: redT_updT_upd dest: redT_updT_Some)

lemma thread_ok_upd:
  "ts t = xln  thread_ok (ts(t  xln')) ta = thread_ok ts ta"
by(rule thread_ok_ts_change) simp

lemma thread_oks_upd:
  "ts t = xln  thread_oks (ts(t  xln')) tas = thread_oks ts tas"
by(rule thread_oks_ts_change) simp

lemma thread_ok_convert_new_thread_action [simp]:
  "thread_ok ts (convert_new_thread_action f ta) = thread_ok ts ta"
by(cases ta) auto

lemma redT_updT'_convert_new_thread_action_eq_None:
  "redT_updT' ts (convert_new_thread_action f ta) t = None  redT_updT' ts ta t = None"
by(cases ta) auto

lemma thread_oks_convert_new_thread_action [simp]:
  "thread_oks ts (map (convert_new_thread_action f) tas) = thread_oks ts tas"
by(induct ts tas rule: thread_oks.induct)(simp_all add: thread_oks_ts_change[OF redT_updT'_convert_new_thread_action_eq_None])

lemma map_redT_updT:
  "map_option (map_prod f id) (redT_updT ts ta t) = 
  redT_updT (λt. map_option (map_prod f id) (ts t)) (convert_new_thread_action f ta) t"
by(cases ta) auto

lemma map_redT_updTs:
  "map_option (map_prod f id) (redT_updTs ts tas t) = 
  redT_updTs (λt. map_option (map_prod f id) (ts t)) (map (convert_new_thread_action f) tas) t"
by(induct tas arbitrary: ts)(auto simp add: map_redT_updT)

end

Theory FWWait

(*  Title:      JinjaThreads/Framework/FWWait.thy
    Author:     Andreas Lochbihler
*)

section ‹Semantics of the thread actions for wait, notify and interrupt›

theory FWWait
imports
  FWState
begin

text ‹Update functions for the wait sets in the multithreaded state›

inductive redT_updW :: "'t  ('w, 't) wait_sets  ('t,'w) wait_set_action  ('w,'t) wait_sets  bool"
for t :: 't and ws :: "('w, 't) wait_sets"
where
  "ws t' = InWS w  redT_updW t ws (Notify w) (ws(t'  PostWS WSNotified))"
| "(t'. ws t'  InWS w)  redT_updW t ws (Notify w) ws"
| "redT_updW t ws (NotifyAll w) (λt. if ws t = InWS w then PostWS WSNotified else ws t)"
| "redT_updW t ws (Suspend w) (ws(t  InWS w))"
| "ws t' = InWS w  redT_updW t ws (WakeUp t') (ws(t'  PostWS WSInterrupted))"
| "(w. ws t'  InWS w)  redT_updW t ws (WakeUp t') ws"
| "redT_updW t ws Notified (ws(t := None))"
| "redT_updW t ws WokenUp (ws(t := None))"

definition redT_updWs :: "'t  ('w,'t) wait_sets  ('t,'w) wait_set_action list  ('w,'t) wait_sets  bool"
where "redT_updWs t = rtrancl3p (redT_updW t)"

inductive_simps redT_updW_simps [simp]:
  "redT_updW t ws (Notify w) ws'"
  "redT_updW t ws (NotifyAll w) ws'"
  "redT_updW t ws (Suspend w) ws'"
  "redT_updW t ws (WakeUp t') ws'"
  "redT_updW t ws WokenUp ws'"
  "redT_updW t ws Notified ws'"

lemma redT_updW_total: "ws'. redT_updW t ws wa ws'"
by(cases wa)(auto simp add: redT_updW.simps)

lemma redT_updWs_total: "ws'. redT_updWs t ws was ws'"
proof(induct was rule: rev_induct)
  case Nil thus ?case by(auto simp add: redT_updWs_def)
next
  case (snoc wa was)
  then obtain ws' where "redT_updWs t ws was ws'" ..
  also from redT_updW_total[of t ws' wa]
  obtain ws'' where "redT_updW t ws' wa ws''" ..
  ultimately show ?case unfolding redT_updWs_def by(auto intro: rtrancl3p_step)
qed

lemma redT_updWs_trans: " redT_updWs t ws was ws'; redT_updWs t ws' was' ws''   redT_updWs t ws (was @ was') ws''"
unfolding redT_updWs_def by(rule rtrancl3p_trans)

lemma redT_updW_None_implies_None:
  " redT_updW t' ws wa ws'; ws t = None; t  t'   ws' t = None"
by(auto simp add: redT_updW.simps)

lemma redT_updWs_None_implies_None:
  assumes "redT_updWs t' ws was ws'"
  and "t  t'" and "ws t = None"
  shows "ws' t = None"
using ‹redT_updWs t' ws was ws' ws t = None› unfolding redT_updWs_def
by induct(auto intro: redT_updW_None_implies_None[OF _ _ t  t'])

lemma redT_updW_PostWS_imp_PostWS:
  " redT_updW t ws wa ws'; ws t'' = PostWS w; t''  t    ws' t'' = PostWS w"
by(auto simp add: redT_updW.simps)

lemma redT_updWs_PostWS_imp_PostWS:
  " redT_updWs t ws was ws'; t''  t; ws t'' = PostWS w   ws' t'' = PostWS w"
unfolding redT_updWs_def 
by(induct rule: rtrancl3p.induct)(auto dest: redT_updW_PostWS_imp_PostWS)

lemma redT_updW_Some_otherD:
  " redT_updW t' ws wa ws'; ws' t = w; t  t'  
   (case w of InWS w'  ws t = InWS w' | _  ws t = w  (w'. ws t = InWS w'))"
by(auto simp add: redT_updW.simps split: if_split_asm wait_set_status.split)

lemma redT_updWs_Some_otherD:
  " redT_updWs t' ws was ws'; ws' t = w; t  t'  
   (case w of InWS w'  ws t = InWS w' | _  ws t = w  (w'. ws t = InWS w'))"
unfolding redT_updWs_def
apply(induct arbitrary: w rule: rtrancl3p.induct)
apply(fastforce split: wait_set_status.splits dest: redT_updW_Some_otherD)+
done

lemma redT_updW_None_SomeD:
  " redT_updW t ws wa ws'; ws' t' = w; ws t' = None   t = t'  (w'. w = InWS w'  wa = Suspend w')"
by(auto simp add: redT_updW.simps split: if_split_asm)

lemma redT_updWs_None_SomeD:
  " redT_updWs t ws was ws'; ws' t' = w; ws t' = None   t = t'  (w'. Suspend w'  set was)"
unfolding redT_updWs_def
proof(induct arbitrary: w rule: rtrancl3p.induct)
  case (rtrancl3p_refl ws) thus ?case by simp
next
  case (rtrancl3p_step ws was ws' wa ws'')
  show ?case
  proof(cases "ws' t'")
    case None
    from redT_updW_None_SomeD[OF ‹redT_updW t ws' wa ws'', OF ws'' t' = w this]
    show ?thesis by auto
  next
    case (Some w')
    with ws t' = None› rtrancl3p_step.hyps(2) show ?thesis by auto
  qed
qed

lemma redT_updW_neq_Some_SomeD:
  " redT_updW t' ws wa ws'; ws' t = InWS w; ws t  InWS w   t = t'  wa = Suspend w"
by(auto simp add: redT_updW.simps split: if_split_asm)

lemma redT_updWs_neq_Some_SomeD:
  " redT_updWs t ws was ws'; ws' t' = InWS w; ws t'  InWS w   t = t'  Suspend w  set was"
unfolding redT_updWs_def
proof(induct rule: rtrancl3p.induct)
  case rtrancl3p_refl thus ?case by simp
next
  case (rtrancl3p_step ws was ws' wa ws'')
  show ?case
  proof(cases "ws' t' = InWS w")
    case True
    with ws t'  InWS w ws' t' = InWS w; ws t'  InWS w  t = t'  Suspend w  set was
    show ?thesis by simp
  next
    case False
    with ‹redT_updW t ws' wa ws'' ws'' t' = InWS w
    have "t' = t  wa = Suspend w" by(rule redT_updW_neq_Some_SomeD)
    thus ?thesis by auto
  qed
qed

lemma redT_updW_not_Suspend_Some:
  " redT_updW t ws wa ws'; ws' t = w'; ws t = w; w. wa  Suspend w 
   w' = w  (w'' w'''. w = InWS w''  w' = PostWS w''')"
by(auto simp add: redT_updW.simps split: if_split_asm)

lemma redT_updWs_not_Suspend_Some:
  " redT_updWs t ws was ws'; ws' t = w'; ws t = w; w. Suspend w  set was 
   w' = w  (w'' w'''. w = InWS w''  w' = PostWS w''')"
unfolding redT_updWs_def
proof(induct arbitrary: w rule: rtrancl3p_converse_induct)
  case refl thus ?case by simp
next
  case (step ws wa ws' was ws'')
  note ws'' t = w'
  moreover  
  have "ws' t  None"
  proof
    assume "ws' t = None"
    with ‹rtrancl3p (redT_updW t) ws' was ws'' ws'' t = w'
    obtain w' where "Suspend w'  set was" unfolding redT_updWs_def[symmetric]
      by(auto dest: redT_updWs_None_SomeD)
    with ‹Suspend w'  set (wa # was) show False by simp
  qed
  then obtain w'' where "ws' t = w''" by auto
  moreover {
    fix w
    from ‹Suspend w  set (wa # was) have "Suspend w  set was" by simp }
  ultimately have "w' = w''  (w''' w''''. w'' = InWS w'''  w' = PostWS w'''')" by(rule step.hyps)
  moreover { fix w
    from ‹Suspend w  set (wa # was) have "wa  Suspend w" by auto }
  note redT_updW_not_Suspend_Some[OF ‹redT_updW t ws wa ws', OF ws' t = w'' ws t = w this]
  ultimately show ?case by auto
qed

lemma redT_updWs_WokenUp_SuspendD:
  " redT_updWs t ws was ws'; Notified  set was  WokenUp  set was; ws' t = w   w. Suspend w  set was"
unfolding redT_updWs_def
by(induct rule: rtrancl3p_converse_induct)(auto dest: redT_updWs_None_SomeD[unfolded redT_updWs_def])

lemma redT_updW_Woken_Up_same_no_Notified_Interrupted:
  " redT_updW t ws wa ws'; ws' t = PostWS w; ws t = PostWS w; w. wa  Suspend w 
   wa  Notified  wa  WokenUp"
by(fastforce)

lemma redT_updWs_Woken_Up_same_no_Notified_Interrupted:
  " redT_updWs t ws was ws'; ws' t = PostWS w; ws t = PostWS w; w. Suspend w  set was 
   Notified  set was  WokenUp  set was"
unfolding redT_updWs_def
proof(induct rule: rtrancl3p_converse_induct)
  case refl thus ?case by simp
next
  case (step ws wa ws' was ws'')
  note Suspend = w. Suspend w  set (wa # was)
  note ws'' t = PostWS w
  moreover have "ws' t = PostWS w"
  proof(cases "ws' t")
    case None
    with ‹rtrancl3p (redT_updW t) ws' was ws'' ws'' t = PostWS w
    obtain w where "Suspend w  set was" unfolding redT_updWs_def[symmetric]
      by(auto dest: redT_updWs_None_SomeD)
    with Suspend[of w] have False by simp
    thus ?thesis ..
  next
    case (Some w')
    thus ?thesis using ws t = PostWS w Suspend ‹redT_updW t ws wa ws'
      by(auto simp add: redT_updW.simps split: if_split_asm)
  qed
  moreover
  { fix w from Suspend[of w] have "Suspend w  set was" by simp }
  ultimately have "Notified  set was  WokenUp  set was" by(rule step.hyps)
  moreover 
  { fix w from Suspend[of w] have "wa  Suspend w" by auto }
  with ‹redT_updW t ws wa ws' ws' t = PostWS w ws t = PostWS w
  have "wa  Notified  wa  WokenUp" by(rule redT_updW_Woken_Up_same_no_Notified_Interrupted)
  ultimately show ?case by auto
qed

text ‹Preconditions for wait set actions›

definition wset_actions_ok :: "('w,'t) wait_sets  't  ('t,'w) wait_set_action list  bool"
where
  "wset_actions_ok ws t was 
  (if Notified  set was then ws t = PostWS WSNotified
   else if WokenUp  set was then ws t = PostWS WSWokenUp
   else ws t = None)"

lemma wset_actions_ok_Nil [simp]:
  "wset_actions_ok ws t []  ws t = None"
by(simp add: wset_actions_ok_def)

definition waiting :: "'w wait_set_status option  bool"
where "waiting w  (w'. w = InWS w')"

lemma not_waiting_iff:
  "¬ waiting w  w = None  (w'. w = PostWS w')"
apply(cases "w")
apply(case_tac [2] a)
apply(auto simp add: waiting_def)
done

lemma waiting_code [code]:
  "waiting None = False"
  "w. waiting PostWS w = False"
  "w. waiting InWS w = True"
by(simp_all add: waiting_def)

end

Theory FWCondAction

(*  Title:      JinjaThreads/Framework/FWCondAction.thy
    Author:     Andreas Lochbihler
*)

section ‹Semantics of the thread actions for purely conditional purpose such as Join›

theory FWCondAction
imports
  FWState
begin

locale final_thread =
  fixes final :: "'x  bool"
begin

primrec cond_action_ok :: "('l,'t,'x,'m,'w) state  't  't conditional_action  bool" where
  "ln. cond_action_ok s t (Join T) = 
   (case thr s T of None  True | (x, ln)  t  T  final x  ln = no_wait_locks  wset s T = None)"
| "cond_action_ok s t Yield = True"

primrec cond_action_oks :: "('l,'t,'x,'m,'w) state  't  't conditional_action list  bool" where
  "cond_action_oks s t [] = True"
| "cond_action_oks s t (ct#cts) = (cond_action_ok s t ct  cond_action_oks s t cts)"

lemma cond_action_oks_append [simp]:
  "cond_action_oks s t (cts @ cts')  cond_action_oks s t cts  cond_action_oks s t cts'"
by(induct cts, auto)

lemma cond_action_oks_conv_set:
  "cond_action_oks s t cts  (ct  set cts. cond_action_ok s t ct)"
by(induct cts) simp_all

lemma cond_action_ok_Join:
  "ln.  cond_action_ok s t (Join T); thr s T = (x, ln)   final x  ln = no_wait_locks  wset s T = None"
by(auto)

lemma cond_action_oks_Join:
  "ln.  cond_action_oks s t cas; Join T  set cas; thr s T = (x, ln)  
   final x  ln = no_wait_locks  wset s T = None  t  T"
by(induct cas)(auto)

lemma cond_action_oks_upd:
  assumes tst: "thr s t = xln"
  shows "cond_action_oks (locks s, (thr s(t  xln'), shr s), wset s, interrupts s) t cas = cond_action_oks s t cas"
proof(induct cas)
  case Nil thus ?case by simp
next
  case (Cons ca cas)
  from tst have eq: "cond_action_ok (locks s, (thr s(t  xln'), shr s), wset s, interrupts s) t ca = cond_action_ok s t ca"
    by(cases ca) auto
  with Cons show ?case by(auto simp del: fun_upd_apply)
qed

lemma cond_action_ok_shr_change:
  "cond_action_ok (ls, (ts, m), ws, is) t ct  cond_action_ok (ls, (ts, m'), ws, is) t ct"
by(cases ct) auto

lemma cond_action_oks_shr_change:
  "cond_action_oks (ls, (ts, m), ws, is) t cts  cond_action_oks (ls, (ts, m'), ws, is) t cts"
by(auto simp add: cond_action_oks_conv_set intro: cond_action_ok_shr_change)

primrec cond_action_ok' :: "('l,'t,'x,'m,'w) state  't  't conditional_action  bool" 
where
  "cond_action_ok' _ _ (Join t) = True"
| "cond_action_ok' _ _ Yield = True"

primrec cond_action_oks' :: "('l,'t,'x,'m,'w) state  't  't conditional_action list  bool" where
  "cond_action_oks' s t [] = True"
| "cond_action_oks' s t (ct#cts) = (cond_action_ok' s t ct  cond_action_oks' s t cts)"

lemma cond_action_oks'_append [simp]:
  "cond_action_oks' s t (cts @ cts')  cond_action_oks' s t cts  cond_action_oks' s t cts'"
by(induct cts, auto)

lemma cond_action_oks'_subset_Join:
  "set cts  insert Yield (range Join)  cond_action_oks' s t cts"
apply(induct cts)
apply(auto)
done

end

definition collect_cond_actions :: "'t conditional_action list  't set" where
  "collect_cond_actions cts = {t. Join t  set cts}"

declare collect_cond_actions_def [simp]

lemma cond_action_ok_final_change:
  " final_thread.cond_action_ok final1 s1 t ca;
     t. thr s1 t = None  thr s2 t = None; 
     t x1.  thr s1 t = (x1, no_wait_locks); final1 x1; wset s1 t = None  
      x2. thr s2 t = (x2, no_wait_locks)  final2 x2  ln2 = no_wait_locks  wset s2 t = None 
   final_thread.cond_action_ok final2 s2 t ca"
apply(cases ca)
apply(fastforce simp add: final_thread.cond_action_ok.simps)+
done

lemma cond_action_oks_final_change:
  assumes major: "final_thread.cond_action_oks final1 s1 t cas"
  and minor: "t. thr s1 t = None  thr s2 t = None"
    "t x1.  thr s1 t = (x1, no_wait_locks); final1 x1; wset s1 t = None  
      x2. thr s2 t = (x2, no_wait_locks)  final2 x2  ln2 = no_wait_locks  wset s2 t = None"
  shows "final_thread.cond_action_oks final2 s2 t cas"
using major
by(induct cas)(auto simp add: final_thread.cond_action_oks.simps intro: cond_action_ok_final_change[OF _ minor])

end

Theory FWWellform

(*  Title:      JinjaThreads/Framework/FWWellform.thy
    Author:     Andreas Lochbihler
*)

section ‹Wellformedness conditions for the multithreaded state›

theory FWWellform
imports
  FWLocking
  FWThread
  FWWait
  FWCondAction
begin

text‹Well-formedness property: Locks are held by real threads›

definition
  lock_thread_ok :: "('l, 't) locks  ('l, 't,'x) thread_info  bool"
where [code del]:
  "lock_thread_ok ls ts  l t. has_lock (ls $ l) t  (xw. ts t = xw)"

lemma lock_thread_ok_code [code]: 
  "lock_thread_ok ls ts = finfun_All ((λl. case l of None  True | (t, n)  (ts t  None)) ∘$ ls)"
by(simp add: lock_thread_ok_def finfun_All_All has_lock_has_locks_conv has_locks_iff o_def)

lemma lock_thread_okI:
  "(l t. has_lock (ls $ l) t  xw. ts t = xw)  lock_thread_ok ls ts"
by(auto simp add: lock_thread_ok_def)

lemma lock_thread_okD:
  " lock_thread_ok ls ts; has_lock (ls $ l) t   xw. ts t = xw"
by(fastforce simp add: lock_thread_ok_def)

lemma lock_thread_okD':
  " lock_thread_ok ls ts; has_locks (ls $ l) t = Suc n   xw. ts t = xw"
by(auto elim: lock_thread_okD[where l=l] simp del: split_paired_Ex)

lemma lock_thread_okE:
  " lock_thread_ok ls ts; l t. has_lock (ls $ l) t  (xw. ts t = xw)  P   P"
by(auto simp add: lock_thread_ok_def simp del: split_paired_Ex)

lemma lock_thread_ok_upd:
  "lock_thread_ok ls ts  lock_thread_ok ls (ts(t  xw))"
by(auto intro!: lock_thread_okI dest: lock_thread_okD)

lemma lock_thread_ok_has_lockE:
  assumes "lock_thread_ok ls ts"
  and "has_lock (ls $ l) t"
  obtains x ln' where "ts t = (x, ln')"
using assms
by(auto dest!: lock_thread_okD)

lemma redT_updLs_preserves_lock_thread_ok:
  assumes lto: "lock_thread_ok ls ts"
  and tst: "ts t = xw"
  shows "lock_thread_ok (redT_updLs ls t las) ts"
proof(rule lock_thread_okI)
  fix L T
  assume ru: "has_lock (redT_updLs ls t las $ L) T"
  show "xw. ts T = xw"
  proof(cases "t = T")
    case True
    thus ?thesis using tst lto
      by(auto elim: lock_thread_okE)
  next
    case False
    with ru have "has_lock (ls $ L) T"
      by(rule redT_updLs_Some_thread_idD) 
    thus ?thesis using lto
      by(auto elim!: lock_thread_okE simp del: split_paired_Ex)
  qed
qed

lemma redT_updTs_preserves_lock_thread_ok:
  assumes lto: "lock_thread_ok ls ts"
  shows "lock_thread_ok ls (redT_updTs ts nts)"
proof(rule lock_thread_okI)
  fix l t
  assume "has_lock (ls $ l) t"
  with lto have "xw. ts t = xw"
    by(auto elim!: lock_thread_okE simp del: split_paired_Ex)
  thus "xw. redT_updTs ts nts t = xw"
    by(auto intro: redT_updTs_Some1 simp del: split_paired_Ex)
qed

lemma lock_thread_ok_has_lock:
  assumes "lock_thread_ok ls ts"
  and "has_lock (ls $ l) t"
  obtains xw where "ts t = xw"
using assms
by(auto dest!: lock_thread_okD)

lemma lock_thread_ok_None_has_locks_0:
  " lock_thread_ok ls ts; ts t = None   has_locks (ls $ l) t = 0"
by(rule ccontr)(auto dest: lock_thread_okD)

lemma redT_upds_preserves_lock_thread_ok:
  "lock_thread_ok ls ts; ts t = xw; thread_oks ts tas
   lock_thread_ok (redT_updLs ls t las) (redT_updTs ts tas(t  xw'))"
apply(rule lock_thread_okI)
apply(clarsimp simp del: split_paired_Ex)
apply(drule has_lock_upd_locks_implies_has_lock, simp)
apply(drule lock_thread_okD, assumption)
apply(erule exE)
by(rule redT_updTs_Some1)

lemma acquire_all_preserves_lock_thread_ok:
  fixes ln
  shows " lock_thread_ok ls ts; ts t = (x, ln)   lock_thread_ok (acquire_all ls t ln) (ts(t  xw))"
by(rule lock_thread_okI)(auto dest!: has_lock_acquire_locks_implies_has_lock dest: lock_thread_okD)

text ‹Well-formedness condition: Wait sets contain only real threads›

definition wset_thread_ok :: "('w, 't) wait_sets  ('l, 't, 'x) thread_info  bool"
where "wset_thread_ok ws ts  t. ts t = None  ws t = None"

lemma wset_thread_okI:
  "(t. ts t = None  ws t = None)  wset_thread_ok ws ts"
by(simp add: wset_thread_ok_def)

lemma wset_thread_okD:
  " wset_thread_ok ws ts; ts t = None   ws t = None"
by(simp add: wset_thread_ok_def)

lemma wset_thread_ok_conv_dom:
  "wset_thread_ok ws ts  dom ws  dom ts"
by(auto simp add: wset_thread_ok_def)

lemma wset_thread_ok_upd:
  "wset_thread_ok ls ts  wset_thread_ok ls (ts(t  xw))"
by(auto intro!: wset_thread_okI dest: wset_thread_okD split: if_split_asm)

lemma wset_thread_ok_upd_None:
  "wset_thread_ok ws ts  wset_thread_ok (ws(t := None)) (ts(t := None))"
by(auto intro!: wset_thread_okI dest: wset_thread_okD split: if_split_asm)

lemma wset_thread_ok_upd_Some:
  "wset_thread_ok ws ts  wset_thread_ok (ws(t := wo)) (ts(t  xln))"
by(auto intro!: wset_thread_okI dest: wset_thread_okD split: if_split_asm)

lemma wset_thread_ok_upd_ws:
  " wset_thread_ok ws ts; ts t = xln   wset_thread_ok (ws(t := w)) ts"
by(auto intro!: wset_thread_okI dest: wset_thread_okD)

lemma wset_thread_ok_NotifyAllI: 
  "wset_thread_ok ws ts  wset_thread_ok (λt. if ws t = w t then w' t else ws t) ts"
by(simp add: wset_thread_ok_def)

lemma redT_updTs_preserves_wset_thread_ok:
  assumes wto: "wset_thread_ok ws ts"
  shows "wset_thread_ok ws (redT_updTs ts nts)"
proof(rule wset_thread_okI)
  fix t
  assume "redT_updTs ts nts t = None"
  hence "ts t = None" by(rule redT_updTs_None)
  with wto show "ws t = None" by(rule wset_thread_okD)
qed

lemma redT_updW_preserve_wset_thread_ok: 
  " wset_thread_ok ws ts; redT_updW t ws wa ws'; ts t = xln   wset_thread_ok ws' ts"
by(fastforce simp add: redT_updW.simps intro: wset_thread_okI wset_thread_ok_NotifyAllI wset_thread_ok_upd_ws dest: wset_thread_okD)

lemma redT_updWs_preserve_wset_thread_ok:
  " wset_thread_ok ws ts; redT_updWs t ws was ws'; ts t = xln   wset_thread_ok ws' ts"
unfolding redT_updWs_def apply(rotate_tac 1)
by(induct rule: rtrancl3p_converse_induct)(auto intro: redT_updW_preserve_wset_thread_ok)

text ‹Well-formedness condition: Wait sets contain only non-final threads›

context final_thread begin

definition wset_final_ok :: "('w, 't) wait_sets  ('l, 't, 'x) thread_info  bool"
where "wset_final_ok ws ts  (t  dom ws. x ln. ts t = (x, ln)  ¬ final x)"

lemma wset_final_okI:
  "(t w. ws t = w  x ln. ts t = (x, ln)  ¬ final x)  wset_final_ok ws ts"
unfolding wset_final_ok_def by(blast)

lemma wset_final_okD:
  " wset_final_ok ws ts; ws t = w   x ln. ts t = (x, ln)  ¬ final x"
unfolding wset_final_ok_def by(blast)

lemma wset_final_okE:
  assumes "wset_final_ok ws ts" "ws t = w"
  and "x ln. ts t = (x, ln)  ¬ final x  thesis"
  shows thesis
using assms by(blast dest: wset_final_okD)

lemma wset_final_ok_imp_wset_thread_ok:
  "wset_final_ok ws ts  wset_thread_ok ws ts"
apply(rule wset_thread_okI)
apply(rule ccontr)
apply(auto elim: wset_final_okE)
done

end

end

Theory FWLockingThread

(*  Title:      JinjaThreads/Framework/FWLockingThread.thy
    Author:     Andreas Lochbihler
*)

section ‹Semantics of the thread action ReleaseAcquire for the thread state›

theory FWLockingThread
imports
  FWLocking
begin

fun upd_threadR :: "nat  't lock  't  lock_action  nat"
where
  "upd_threadR n l t ReleaseAcquire = n + has_locks l t"
| "upd_threadR n l t _ = n"

primrec upd_threadRs :: "nat  't lock  't  lock_action list  nat"
where
  "upd_threadRs n l t [] = n"
| "upd_threadRs n l t (la # las) = upd_threadRs (upd_threadR n l t la) (upd_lock l t la) t las"

lemma upd_threadRs_append [simp]:
  "upd_threadRs n l t (las @ las') = upd_threadRs (upd_threadRs n l t las) (upd_locks l t las) t las'"
by(induct las arbitrary: n l, auto)

definition redT_updLns :: "('l,'t) locks  't  ('l ⇒f nat)  'l lock_actions  ('l ⇒f nat)"
where "ln. redT_updLns ls t ln las = (λ(l, n, la). upd_threadRs n l t la) ∘$ ($ls, ($ln, las$)$)"

lemma redT_updLns_iff [simp]:
  "ln. redT_updLns ls t ln las $ l = upd_threadRs (ln $ l) (ls $ l) t (las $ l)"
by(simp add: redT_updLns_def)

lemma upd_threadRs_comp_empty [simp]: "(λ(l, n, las). upd_threadRs n l t las) ∘$ ($ls, ($lns, K$ []$)$) = lns"
by(auto intro!: finfun_ext)

lemma redT_updLs_empty [simp]: "redT_updLs ls t (K$ []) = ls"
by(simp add: redT_updLs_def)

end

Theory FWInterrupt

(*  Title:      JinjaThreads/Framework/FWInterrupt.thy
    Author:     Andreas Lochbihler
*)

section ‹Semantics of the thread actions for interruption›

theory FWInterrupt
imports
  FWState
begin

primrec redT_updI :: "'t interrupts  't interrupt_action  't interrupts"
where
  "redT_updI is (Interrupt t) = insert t is"
| "redT_updI is (ClearInterrupt t) = is - {t}"
| "redT_updI is (IsInterrupted t b) = is"

fun redT_updIs :: "'t interrupts  't interrupt_action list  't interrupts"
where
  "redT_updIs is [] = is"
| "redT_updIs is (ia # ias) = redT_updIs (redT_updI is ia) ias"

primrec interrupt_action_ok :: "'t interrupts  't interrupt_action  bool"
where
  "interrupt_action_ok is (Interrupt t) = True"
| "interrupt_action_ok is (ClearInterrupt t) = True"
| "interrupt_action_ok is (IsInterrupted t b) = (b = (t  is))"

fun interrupt_actions_ok :: "'t interrupts  't interrupt_action list  bool"
where
  "interrupt_actions_ok is [] = True"
| "interrupt_actions_ok is (ia # ias)  interrupt_action_ok is ia  interrupt_actions_ok (redT_updI is ia) ias"

primrec interrupt_action_ok' :: "'t interrupts  't interrupt_action  bool"
where
  "interrupt_action_ok' is (Interrupt t) = True"
| "interrupt_action_ok' is (ClearInterrupt t) = True"
| "interrupt_action_ok' is (IsInterrupted t b) = (b  t  is)"

fun interrupt_actions_ok' :: "'t interrupts  't interrupt_action list  bool"
where
  "interrupt_actions_ok' is [] = True"
| "interrupt_actions_ok' is (ia # ias)  interrupt_action_ok' is ia  interrupt_actions_ok' (redT_updI is ia) ias"

fun collect_interrupt :: "'t interrupt_action  't set  't set"
where
  "collect_interrupt (IsInterrupted t True) Ts = insert t Ts"
| "collect_interrupt (Interrupt t) Ts = Ts - {t}"
| "collect_interrupt _ Ts = Ts"

definition collect_interrupts :: "'t interrupt_action list  't set"
where "collect_interrupts ias = foldr collect_interrupt ias {}"

lemma collect_interrupts_interrupted:
  " interrupt_actions_ok is ias; t'  collect_interrupts ias   t'  is"
unfolding collect_interrupts_def
proof(induct ias arbitrary: "is")
  case Nil thus ?case by simp
next
  case (Cons ia ias) thus ?case
    by(cases "(ia, foldr collect_interrupt ias {})" rule: collect_interrupt.cases) auto
qed

lemma interrupt_actions_ok_append [simp]:
  "interrupt_actions_ok is (ias @ ias')  interrupt_actions_ok is ias  interrupt_actions_ok (redT_updIs is ias) ias'"
by(induct ias arbitrary: "is") auto

lemma collect_interrupt_subset: "Ts  Ts'  collect_interrupt ia Ts  collect_interrupt ia Ts'"
by(cases "(ia, Ts)" rule: collect_interrupt.cases) auto

lemma foldr_collect_interrupt_subset:
  "Ts  Ts'  foldr collect_interrupt ias Ts  foldr collect_interrupt ias Ts'"
by(induct ias)(simp_all add: collect_interrupt_subset)

lemma interrupt_actions_ok_all_nthI:
  assumes "n. n < length ias  interrupt_action_ok (redT_updIs is (take n ias)) (ias ! n)"
  shows "interrupt_actions_ok is ias"
using assms
proof(induct ias arbitrary: "is")
  case Nil thus ?case by simp
next
  case (Cons ia ias)
  from Cons.prems[of 0] have "interrupt_action_ok is ia" by simp
  moreover
  { fix n
    assume "n < length ias"
    hence "interrupt_action_ok (redT_updIs (redT_updI is ia) (take n ias)) (ias ! n)"
      using Cons.prems[of "Suc n"] by simp }
  hence "interrupt_actions_ok (redT_updI is ia) ias" by(rule Cons.hyps)
  ultimately show ?case by simp
qed

lemma interrupt_actions_ok_nthD:
  assumes "interrupt_actions_ok is ias"
  and "n < length ias"
  shows "interrupt_action_ok (redT_updIs is (take n ias)) (ias ! n)"
using assms
by(induct n arbitrary: "is" ias)(case_tac [!] ias, auto)

lemma interrupt_actions_ok'_all_nthI:
  assumes "n. n < length ias  interrupt_action_ok' (redT_updIs is (take n ias)) (ias ! n)"
  shows "interrupt_actions_ok' is ias"
using assms
proof(induct ias arbitrary: "is")
  case Nil thus ?case by simp
next
  case (Cons ia ias)
  from Cons.prems[of 0] have "interrupt_action_ok' is ia" by simp
  moreover
  { fix n
    assume "n < length ias"
    hence "interrupt_action_ok' (redT_updIs (redT_updI is ia) (take n ias)) (ias ! n)"
      using Cons.prems[of "Suc n"] by simp }
  hence "interrupt_actions_ok' (redT_updI is ia) ias" by(rule Cons.hyps)
  ultimately show ?case by simp
qed

lemma interrupt_actions_ok'_nthD:
  assumes "interrupt_actions_ok' is ias"
  and "n < length ias"
  shows "interrupt_action_ok' (redT_updIs is (take n ias)) (ias ! n)"
using assms
by(induct n arbitrary: "is" ias)(case_tac [!] ias, auto)

lemma interrupt_action_ok_imp_interrupt_action_ok' [simp]:
  "interrupt_action_ok is ia  interrupt_action_ok' is ia"
by(cases ia) simp_all

lemma interrupt_actions_ok_imp_interrupt_actions_ok' [simp]:
  "interrupt_actions_ok is ias  interrupt_actions_ok' is ias"
by(induct ias arbitrary: "is")(simp_all)

lemma collect_interruptsE:
  assumes "t'  collect_interrupts ias'"
  obtains n' where "n' < length ias'" "ias' ! n' = IsInterrupted t' True"
  and "Interrupt t'  set (take n' ias')"
proof(atomize_elim)
  from assms show "n'<length ias'. ias' ! n' = IsInterrupted t' True  Interrupt t'  set (take n' ias')"
    unfolding collect_interrupts_def
  proof(induct ias' arbitrary: t')
    case Nil thus ?case by simp
  next
    case (Cons ia ias) thus ?case
      by(cases "(ia, foldr collect_interrupt ias {})" rule: collect_interrupt.cases) fastforce+
  qed
qed

lemma collect_interrupts_prefix:
  "collect_interrupts ias  collect_interrupts (ias @ ias')"
by (metis Un_empty collect_interrupts_def foldr_append foldr_collect_interrupt_subset inf_sup_ord(1) inf_sup_ord(2) subset_Un_eq)

lemma redT_updI_insert_Interrupt:
  " t  redT_updI is ia; t  is   ia = Interrupt t"
by(cases ia) simp_all

lemma redT_updIs_insert_Interrupt:
  " t  redT_updIs is ias; t  is   Interrupt t  set ias"
proof(induct ias arbitrary: "is")
  case Nil thus ?case by simp
next
  case (Cons ia ias) thus ?case
    by(cases "t  redT_updI is ia")(auto dest: redT_updI_insert_Interrupt)
qed

lemma interrupt_actions_ok_takeI:
  "interrupt_actions_ok is ias  interrupt_actions_ok is (take n ias)"
by(subst (asm) append_take_drop_id[symmetric, where n=n])(simp del: append_take_drop_id)

lemma interrupt_actions_ok'_collect_interrupts_imp_interrupt_actions_ok:
  assumes int: "interrupt_actions_ok' is ias"
  and ci: "collect_interrupts ias  is"
  and int': "interrupt_actions_ok is' ias"
  shows "interrupt_actions_ok is ias"
proof(rule interrupt_actions_ok_all_nthI)
  fix n
  assume n: "n < length ias"
  show "interrupt_action_ok (redT_updIs is (take n ias)) (ias ! n)"
  proof(cases "t. ias ! n = IsInterrupted t True")
    case False
    with interrupt_actions_ok'_nthD[OF int n] show ?thesis by(cases "ias ! n") simp_all
  next
    case True
    then obtain t where ia: "ias ! n = IsInterrupted t True" ..
    from int' n have "interrupt_action_ok (redT_updIs is' (take n ias)) (ias ! n)" by(rule interrupt_actions_ok_nthD)
    with ia have "t  redT_updIs is' (take n ias)" by simp
    moreover have "ias = take (Suc n) ias @ drop (Suc n) ias" by simp
    with ci have "collect_interrupts (take (Suc n) ias)  is"
      by (metis collect_interrupts_prefix subset_trans)
    ultimately have "t  redT_updIs is (take n ias)" using n ia int int'
    proof(induct n arbitrary: "is" is' ias)
      case 0 thus ?case by(clarsimp simp add: neq_Nil_conv collect_interrupts_def)
    next
      case (Suc n)
      from ‹Suc n < length ias obtain ia ias'
        where ias [simp]: "ias = ia # ias'" by(cases ias) auto
      from ‹interrupt_actions_ok is' ias
      have ia_ok: "interrupt_action_ok is' ia" by simp
        
      from t  redT_updIs is' (take (Suc n) ias)
      have "t  redT_updIs (redT_updI is' ia) (take n ias')" by simp
      moreover from ‹collect_interrupts (take (Suc (Suc n)) ias)  is ia_ok
      have "collect_interrupts (take (Suc n) ias')  redT_updI is ia"
      proof(cases "(ia, is)" rule: collect_interrupt.cases)
        case ("3_2" t' Ts)
        hence [simp]: "ia = ClearInterrupt t'" "Ts = is" by simp_all
        have "t'  collect_interrupts (take (Suc n) ias')"
        proof
          assume "t'  collect_interrupts (take (Suc n) ias')"
          then obtain n' where "n' < length (take (Suc n) ias')" "take (Suc n) ias' ! n' = IsInterrupted t' True"
            "Interrupt t'  set (take n' (take (Suc n) ias'))" by(rule collect_interruptsE)
          hence "n'  n" "ias' ! n' = IsInterrupted t' True" "Interrupt t'  set (take n' ias')"
            using ‹Suc n < length ias by(simp_all add: min_def split: if_split_asm)
          hence "Suc n' < length ias" using ‹Suc n < length ias by(simp add: min_def)
          with ‹interrupt_actions_ok is' ias 
          have "interrupt_action_ok (redT_updIs is' (take (Suc n') ias)) (ias ! Suc n')"
            by(rule interrupt_actions_ok_nthD)
          with ‹Suc n < length ias ias' ! n' = IsInterrupted t' True›
          have "t'  redT_updIs (is' - {t'}) (take n' ias')" by simp
          hence "Interrupt t'  set (take n' ias')"
            by(rule redT_updIs_insert_Interrupt) simp
          with ‹Interrupt t'  set (take n' ias') show False by contradiction
        qed
        thus ?thesis using ‹collect_interrupts (take (Suc (Suc n)) ias)  is
          by(auto simp add: collect_interrupts_def)
      qed(auto simp add: collect_interrupts_def)
      moreover from ‹Suc n < length ias have "n < length ias'" by simp
      moreover from ias ! Suc n = IsInterrupted t True› have "ias' ! n = IsInterrupted t True" by simp
      moreover from ‹interrupt_actions_ok' is ias have "interrupt_actions_ok' (redT_updI is ia) ias'"
        unfolding ias by simp
      moreover from ‹interrupt_actions_ok is' ias have "interrupt_actions_ok (redT_updI is' ia) ias'" by simp
      ultimately have "t  redT_updIs (redT_updI is ia) (take n ias')" by(rule Suc)
      thus ?case by simp
    qed
    thus ?thesis unfolding ia by simp
  qed
qed

end

Theory FWSemantics

(*  Title:      JinjaThreads/Framework/FWSemantics.thy
    Author:     Andreas Lochbihler
*)

section ‹The multithreaded semantics›

theory FWSemantics
imports
  FWWellform
  FWLockingThread
  FWCondAction
  FWInterrupt
begin

inductive redT_upd :: "('l,'t,'x,'m,'w) state  't  ('l,'t,'x,'m,'w,'o) thread_action  'x  'm  ('l,'t,'x,'m,'w) state  bool"
for s t ta x' m'
where
  "redT_updWs t (wset s) taw ws'
   redT_upd s t ta x' m' (redT_updLs (locks s) t tal, ((redT_updTs (thr s) tat)(t  (x', redT_updLns (locks s) t (snd (the (thr s t))) tal)), m'), ws', redT_updIs (interrupts s) tai)"

inductive_simps redT_upd_simps [simp]:
  "redT_upd s t ta x' m' s'"

definition redT_acq :: "('l,'t,'x,'m,'w) state  't  ('l ⇒f nat)  ('l,'t,'x,'m,'w) state"
where
  "ln. redT_acq s t ln = (acquire_all (locks s) t ln, ((thr s)(t  (fst (the (thr s t)), no_wait_locks)), shr s), wset s, interrupts s)"

context final_thread begin

inductive actions_ok :: "('l,'t,'x,'m,'w) state  't  ('l,'t,'x','m,'w,'o) thread_action  bool"
  for s :: "('l,'t,'x,'m,'w) state" and t :: 't and ta :: "('l,'t,'x','m,'w,'o) thread_action"
  where
  " lock_ok_las (locks s) t tal; thread_oks (thr s) tat; cond_action_oks s t tac;
     wset_actions_ok (wset s) t taw; interrupt_actions_ok (interrupts s) tai 
   actions_ok s t ta"

declare actions_ok.intros [intro!]
declare actions_ok.cases [elim!]

lemma actions_ok_iff [simp]:
  "actions_ok s t ta 
   lock_ok_las (locks s) t tal  thread_oks (thr s) tat  cond_action_oks s t tac 
   wset_actions_ok (wset s) t taw  interrupt_actions_ok (interrupts s) tai"
by(auto)

lemma actions_ok_thread_oksD:
  "actions_ok s t ta  thread_oks (thr s) tat"
by(erule actions_ok.cases)

inductive actions_ok' :: "('l,'t,'x,'m,'w) state  't  ('l,'t,'x','m,'w,'o) thread_action  bool" where
  " lock_ok_las' (locks s) t tal; thread_oks (thr s) tat; cond_action_oks' s t tac;
     wset_actions_ok (wset s) t taw; interrupt_actions_ok' (interrupts s) tai 
   actions_ok' s t ta"

declare actions_ok'.intros [intro!]
declare actions_ok'.cases [elim!]

lemma actions_ok'_iff:
  "actions_ok' s t ta 
   lock_ok_las' (locks s) t tal  thread_oks (thr s) tat  cond_action_oks' s t tac 
   wset_actions_ok (wset s) t taw  interrupt_actions_ok' (interrupts s) tai"
by auto

lemma actions_ok'_ta_upd_obs:
  "actions_ok' s t (ta_update_obs ta obs)  actions_ok' s t ta"
by(auto simp add: actions_ok'_iff lock_ok_las'_def ta_upd_simps wset_actions_ok_def)

lemma actions_ok'_empty: "actions_ok' s t ε  wset s t = None"
by(simp add: actions_ok'_iff lock_ok_las'_def)

lemma actions_ok'_convert_extTA:
  "actions_ok' s t (convert_extTA f ta) = actions_ok' s t ta"
by(simp add: actions_ok'_iff)

inductive actions_subset :: "('l,'t,'x,'m,'w,'o) thread_action  ('l,'t,'x','m,'w,'o) thread_action  bool"
where
 " collect_locks' ta'l  collect_locks tal; 
    collect_cond_actions ta'c  collect_cond_actions tac;
    collect_interrupts ta'i  collect_interrupts tai 
   actions_subset ta' ta"

declare actions_subset.intros [intro!]
declare actions_subset.cases [elim!]

lemma actions_subset_iff:
  "actions_subset ta' ta  
   collect_locks' ta'l  collect_locks tal 
   collect_cond_actions ta'c  collect_cond_actions tac 
   collect_interrupts ta'i  collect_interrupts tai"
by auto

lemma actions_subset_refl [intro]:
  "actions_subset ta ta"
by(auto intro: actions_subset.intros collect_locks'_subset_collect_locks del: subsetI)

definition final_thread :: "('l,'t,'x,'m,'w) state  't  bool" where
  "ln. final_thread s t  (case thr s t of None  False | (x, ln)  final x  ln = no_wait_locks  wset s t = None)"

definition final_threads :: "('l,'t,'x,'m,'w) state  't set" 
where "final_threads s  {t. final_thread s t}"

lemma [iff]: "t  final_threads s = final_thread s t"
  by (simp add: final_threads_def)

lemma [pred_set_conv]: "final_thread s = (λt. t  final_threads s)"
  by simp

definition mfinal :: "('l,'t,'x,'m,'w) state  bool"
where "mfinal s  (t x ln. thr s t = (x, ln)  final x  ln = no_wait_locks  wset s t = None)"

lemma final_threadI:
  " thr s t = (x, no_wait_locks); final x; wset s t = None   final_thread s t"
by(simp add: final_thread_def)

lemma final_threadE:
  assumes "final_thread s t"
  obtains x where "thr s t = (x, no_wait_locks)" "final x" "wset s t = None"
using assms by(auto simp add: final_thread_def)

lemma mfinalI:
  "(t x ln. thr s t = (x, ln)  final x  ln = no_wait_locks  wset s t = None)  mfinal s"
unfolding mfinal_def by blast

lemma mfinalD:
  fixes ln
  assumes "mfinal s" "thr s t = (x, ln)"
  shows "final x" "ln = no_wait_locks" "wset s t = None"
using assms unfolding mfinal_def by blast+

lemma mfinalE:
  fixes ln
  assumes "mfinal s" "thr s t = (x, ln)"
  obtains "final x" "ln = no_wait_locks" "wset s t = None"
using mfinalD[OF assms] by(rule that)

lemma mfinal_def2: "mfinal s  dom (thr s)  final_threads s"
by(fastforce elim: mfinalE final_threadE intro: mfinalI final_threadI)

end

locale multithreaded_base = final_thread +
  constrains final :: "'x  bool" 
  fixes r :: "('l,'t,'x,'m,'w,'o) semantics" ("_  _ -_ _" [50,0,0,50] 80)
  and convert_RA :: "'l released_locks  'o list"
begin

abbreviation
  r_syntax :: "'t  'x  'm  ('l,'t,'x,'m,'w,'o) thread_action  'x  'm  bool"
              ("_  _, _ -_ _, _" [50,0,0,0,0,0] 80)
where
  "t  x, m -ta x', m'  t  (x, m) -ta (x', m')"

inductive
  redT :: "('l,'t,'x,'m,'w) state  't × ('l,'t,'x,'m,'w,'o) thread_action  ('l,'t,'x,'m,'w) state  bool" and
  redT_syntax1 :: "('l,'t,'x,'m,'w) state  't  ('l,'t,'x,'m,'w,'o) thread_action  ('l,'t,'x,'m,'w) state  bool" ("_ -__ _" [50,0,0,50] 80)
where
  "s -tta s'  redT s (t, ta) s'"

|  redT_normal:
  " t  x, shr s -ta x', m';
     thr s t = (x, no_wait_locks);
     actions_ok s t ta;
     redT_upd s t ta x' m' s' 
   s -tta s'"

| redT_acquire:
  "ln.  thr s t = (x, ln); ¬ waiting (wset s t);
     may_acquire_all (locks s) t ln; ln $ n > 0;
     s' = (acquire_all (locks s) t ln, (thr s(t  (x, no_wait_locks)), shr s), wset s, interrupts s) 
   s -t((K$ []), [], [], [], [], convert_RA ln) s'"

abbreviation
  redT_syntax2 :: "('l,'t) locks  ('l,'t,'x) thread_info × 'm  ('w,'t) wait_sets  't interrupts
                    't  ('l,'t,'x,'m,'w,'o) thread_action
                    ('l,'t) locks  ('l,'t,'x) thread_info × 'm  ('w,'t) wait_sets  't interrupts  bool"
                  ("_, _, _, _ -__ _, _, _, _" [0,0,0,0,0,0,0,0,0] 80)
where
  "ls, tsm, ws, is -tta ls', tsm', ws', is'  (ls, tsm, ws, is) -tta (ls', tsm', ws', is')"


lemma redT_elims [consumes 1, case_names normal acquire]:
  assumes red: "s -tta s'"
  and normal: "x x' m' ws'.
     t  x, shr s -ta x', m';
      thr s t = (x, no_wait_locks);
      lock_ok_las (locks s) t tal;
      thread_oks (thr s) tat;
      cond_action_oks s t tac;
      wset_actions_ok (wset s) t taw;
      interrupt_actions_ok (interrupts s) tai;
      redT_updWs t (wset s) taw ws';
      s' = (redT_updLs (locks s) t tal, (redT_updTs (thr s) tat(t  (x', redT_updLns (locks s) t no_wait_locks tal)), m'), ws', redT_updIs (interrupts s) tai) 
     thesis"
   and acquire: "x ln n.
     thr s t = (x, ln);
      ta = (K$ [], [], [], [], [], convert_RA ln);
      ¬ waiting (wset s t);
      may_acquire_all (locks s) t ln; 0 < ln $ n;
      s' = (acquire_all (locks s) t ln, (thr s(t  (x, no_wait_locks)), shr s), wset s, interrupts s) 
     thesis"
  shows thesis
using red
proof cases
  case redT_normal
  thus ?thesis using normal by(cases s')(auto)
next
  case redT_acquire
  thus ?thesis by-(rule acquire, fastforce+)
qed

definition
  RedT :: "('l,'t,'x,'m,'w) state  ('t × ('l,'t,'x,'m,'w,'o) thread_action) list  ('l,'t,'x,'m,'w) state  bool"
          ("_ -▹_→* _" [50,0,50] 80)
where
  "RedT  rtrancl3p redT"

lemma RedTI:
  "rtrancl3p redT s ttas s'  RedT s ttas s'"
by(simp add: RedT_def)

lemma RedTE:
  " RedT s ttas s'; rtrancl3p redT s ttas s'  P   P"
by(auto simp add: RedT_def)

lemma RedTD:
  "RedT s ttas s'  rtrancl3p redT s ttas s'"
by(simp add: RedT_def)

lemma RedT_induct [consumes 1, case_names refl step]:
  " s -▹ttas→* s';
     s. P s [] s;
     s ttas s' t ta s''.  s -▹ttas→* s'; P s ttas s'; s' -tta s''   P s (ttas @ [(t, ta)]) s''
   P s ttas s'"
unfolding RedT_def
by(erule rtrancl3p.induct) auto

lemma RedT_induct' [consumes 1, case_names refl step]:
  " s -▹ttas→* s';
     P s [] s;
     ttas s' t ta s''.  s -▹ttas→* s'; P s ttas s'; s' -tta s''   P s (ttas @ [(t, ta)]) s''
   P s ttas s'"
  unfolding RedT_def
apply(erule rtrancl3p_induct', blast)
apply(case_tac b, blast)
done

lemma RedT_lift_preserveD:
  assumes Red: "s -▹ttas→* s'"
  and P: "P s"
  and preserve: "s t tas s'.  s -ttas s'; P s   P s'"
  shows "P s'"
  using Red P
  by(induct rule: RedT_induct)(auto intro: preserve)

lemma RedT_refl [intro, simp]:
  "s -▹[]→* s"
by(rule RedTI)(rule rtrancl3p_refl)

lemma redT_has_locks_inv:
  " ls, (ts, m), ws, is -tta ls', (ts', m'), ws', is'; t  t'  
  has_locks (ls $ l) t' = has_locks (ls' $ l) t'"
by(auto elim!: redT.cases intro: redT_updLs_has_locks[THEN sym, simplified] may_acquire_all_has_locks_acquire_locks[symmetric])

lemma redT_has_lock_inv:
  " ls, (ts, m), ws, is -tta ls', (ts', m'), ws', is'; t  t' 
   has_lock (ls' $ l) t' = has_lock (ls $ l) t'"
by(auto simp add: redT_has_locks_inv)

lemma redT_ts_Some_inv:
  " ls, (ts, m), ws, is -tta ls', (ts', m'), ws', is'; t  t'; ts t' = x   ts' t' = x"
by(fastforce elim!: redT.cases simp: redT_updTs_upd[THEN sym] intro: redT_updTs_Some)

lemma redT_thread_not_disappear:
  " s -tta s'; thr s' t' = None  thr s t' = None"
apply(cases "t  t'")
apply(auto elim!: redT_elims simp add: redT_updTs_upd[THEN sym] intro: redT_updTs_None)
done

lemma RedT_thread_not_disappear:
  " s -▹ttas→* s'; thr s' t' = None  thr s t' = None"
apply(erule contrapos_pp[where Q="thr s' t' = None"])
apply(drule (1) RedT_lift_preserveD)
apply(erule_tac Q="thr sa t' = None" in contrapos_nn)
apply(erule redT_thread_not_disappear)
apply(auto)
done

lemma redT_preserves_wset_thread_ok:
  " s -tta s'; wset_thread_ok (wset s) (thr s)   wset_thread_ok (wset s') (thr s')"
by(fastforce elim!: redT.cases intro: wset_thread_ok_upd redT_updTs_preserves_wset_thread_ok redT_updWs_preserve_wset_thread_ok)

lemma RedT_preserves_wset_thread_ok:
  " s -▹ttas→* s'; wset_thread_ok (wset s) (thr s)   wset_thread_ok (wset s') (thr s')"
by(erule (1) RedT_lift_preserveD)(erule redT_preserves_wset_thread_ok)

lemma redT_new_thread_ts_Some:
  " s -tta s'; NewThread t' x m''  set tat; wset_thread_ok (wset s) (thr s) 
   thr s' t' = (x, no_wait_locks)"
by(erule redT_elims)(auto dest: thread_oks_new_thread elim: redT_updTs_new_thread_ts)

lemma RedT_new_thread_ts_not_None:
  " s -▹ttas→* s'; NewThread t x m''  set (concat (map (thr_a  snd) ttas)); wset_thread_ok (wset s) (thr s) 
    thr s' t  None"
proof(induct rule: RedT_induct)
  case refl thus ?case by simp
next
  case (step S TTAS S' T TA S'')
  note Red = S -▹TTAS→* S'
  note IH =  NewThread t x m''  set (concat (map (thr_a  snd) TTAS)); wset_thread_ok (wset S) (thr S)   thr S' t  None›
  note red = S' -TTA S''
  note ins = ‹NewThread t x m''  set (concat (map (thr_a  snd) (TTAS @ [(T, TA)])))
  note wto = ‹wset_thread_ok (wset S) (thr S)
  from Red wto have wto': "wset_thread_ok (wset S') (thr S')" by(auto dest: RedT_preserves_wset_thread_ok)  
  show ?case
  proof(cases "NewThread t x m''  set TAt")
    case True thus ?thesis using red wto'
      by(auto dest!: redT_new_thread_ts_Some)
  next
    case False
    hence "NewThread t x m''  set (concat (map (thr_a  snd) TTAS))" using ins by(auto)
    hence "thr S' t  None" using wto by(rule IH)
    with red show ?thesis
      by -(erule contrapos_nn, auto dest: redT_thread_not_disappear)
  qed
qed

lemma redT_preserves_lock_thread_ok:
  " s -tta s'; lock_thread_ok (locks s) (thr s)   lock_thread_ok (locks s') (thr s')"
by(auto elim!: redT_elims intro: redT_upds_preserves_lock_thread_ok acquire_all_preserves_lock_thread_ok)

lemma RedT_preserves_lock_thread_ok:
  " s -▹ttas→* s'; lock_thread_ok (locks s) (thr s)   lock_thread_ok (locks s') (thr s')"
by(erule (1) RedT_lift_preserveD)(erule redT_preserves_lock_thread_ok)

lemma redT_ex_new_thread:
  assumes "s -t'ta s'" "wset_thread_ok (wset s) (thr s)" "thr s' t = (x, w)" "thr s t = None"
  shows "m. NewThread t x m  set tat  w = no_wait_locks"
using assms
by cases (fastforce split: if_split_asm dest: wset_thread_okD redT_updTs_new_thread)+

lemma redT_ex_new_thread':
  assumes "s -t'ta s'" "thr s' t = (x, w)" "thr s t = None"
  shows "m x. NewThread t x m  set tat"
using assms
by(cases)(fastforce split: if_split_asm dest!: redT_updTs_new_thread)+

definition deterministic :: "('l,'t,'x,'m,'w) state set  bool"
where
  "deterministic I  
  (s t x ta' x' m' ta'' x'' m''. 
    s  I
     thr s t = (x, no_wait_locks)
     t  x, shr s -ta' x', m' 
     t  x, shr s -ta'' x'', m'' 
     actions_ok s t ta'  actions_ok s t ta''
     ta' = ta''  x' = x''  m' = m'')  invariant3p redT I"

lemma determisticI:
  "s t x ta' x' m' ta'' x'' m''.
       s  I; thr s t = (x, no_wait_locks); 
        t  x, shr s -ta' x', m'; t  x, shr s -ta'' x'', m''; 
        actions_ok s t ta'; actions_ok s t ta'' 
       ta' = ta''  x' = x''  m' = m'';
    invariant3p redT I 
   deterministic I"
unfolding deterministic_def by blast

lemma deterministicD:
  " deterministic I;
    t  x, shr s -ta' x', m'; t  x, shr s -ta'' x'', m'';
    thr s t = (x, no_wait_locks); actions_ok s t ta'; actions_ok s t ta''; s  I 
   ta' = ta''  x' = x''  m' = m''"
unfolding deterministic_def by blast

lemma deterministic_invariant3p:
  "deterministic I  invariant3p redT I"
unfolding deterministic_def by blast

lemma deterministic_THE:
  " deterministic I; thr s t = (x, no_wait_locks); t  x, shr s -ta x', m'; actions_ok s t ta; s  I 
   (THE (ta, x', m'). t  x, shr s -ta x', m'  actions_ok s t ta) = (ta, x', m')"
by(rule the_equality)(blast dest: deterministicD)+

end

locale multithreaded = multithreaded_base +
  constrains final :: "'x  bool"
  and r :: "('l,'t,'x,'m,'w,'o) semantics"
  and convert_RA :: "'l released_locks  'o list"
  assumes new_thread_memory: " t  s -ta s'; NewThread t' x m  set tat   m = snd s'"
  and final_no_red: " t  (x, m) -ta (x', m'); final x   False"
begin

lemma redT_new_thread_common:
  " s -tta s'; NewThread t' x m''  set tat; taw = []   m'' = shr s'"
by(auto elim!: redT_elims rtrancl3p_cases dest: new_thread_memory)

lemma redT_new_thread:
  assumes "s -t'ta s'" "thr s' t = (x, w)" "thr s t = None" "taw = []"
  shows "NewThread t x (shr s')  set tat  w = no_wait_locks"
using assms
apply(cases rule: redT_elims)
apply(auto split: if_split_asm del: conjI elim!: rtrancl3p_cases)
apply(drule (2) redT_updTs_new_thread)
apply(auto dest: new_thread_memory)
done

lemma final_no_redT: 
  " s -tta s'; thr s t = (x, no_wait_locks)   ¬ final x"
by(auto elim!: redT_elims dest: final_no_red)

lemma mfinal_no_redT:
  assumes redT: "s -tta s'" and mfinal: "mfinal s"
  shows False
using redT mfinalD[OF mfinal, of t]
by cases (metis final_no_red, metis neq_no_wait_locks_conv)

end

end

Theory FWProgressAux

(*  Title:      JinjaThreads/Framework/FWProgressAux.thy
    Author:     Andreas Lochbihler
*)

section ‹Auxiliary definitions for the progress theorem for the multithreaded semantics›

theory FWProgressAux
imports
  FWSemantics
begin

abbreviation collect_waits :: "('l,'t,'x,'m,'w,'o) thread_action  ('l + 't + 't) set"
where "collect_waits ta  collect_locks tal <+> collect_cond_actions tac <+> collect_interrupts tai"

lemma collect_waits_unfold:
  "collect_waits ta = {l. Lock  set (tal $ l)} <+> {t. Join t  set tac} <+> collect_interrupts tai"
by(simp add: collect_locks_def)

context multithreaded_base begin

definition must_sync :: "'t  'x  'm  bool" ("_  _,/ _/ " [50, 0,0] 81) where
  "t  x, m   (ta x' m' s. t  x, m -ta x', m'  shr s = m  actions_ok s t ta)"

lemma must_sync_def2:
  "t  x, m   (ta x' m' s. t  x, m -ta x', m'  actions_ok s t ta)"
by(fastforce simp add: must_sync_def intro: cond_action_oks_shr_change)

lemma must_syncI:
  "ta x' m' s. t  x, m -ta x', m'  actions_ok s t ta  t  x, m "
by(fastforce simp add: must_sync_def2)

lemma must_syncE:
  " t  x, m ; ta x' m' s.  t  x, m -ta x', m'; actions_ok s t ta; m = shr s   thesis   thesis"
by(fastforce simp only: must_sync_def)

definition can_sync :: "'t  'x  'm  ('l + 't + 't) set  bool" ("_  _,/ _/ _/ " [50,0,0,0] 81) where
  "t  x, m LT   ta x' m'. t  x, m -ta x', m'  (LT = collect_waits ta)"

lemma can_syncI:
  " t  x, m -ta x', m';
     LT = collect_waits ta 
   t  x, m LT "
by(cases ta)(fastforce simp add: can_sync_def)

lemma can_syncE:
  assumes "t  x, m LT "
  obtains ta x' m'
  where "t  x, m -ta x', m'"
  and "LT = collect_waits ta"
  using assms
by(clarsimp simp add: can_sync_def)

inductive_set active_threads :: "('l,'t,'x,'m,'w) state  't set"
for s :: "('l,'t,'x,'m,'w) state"
where
  normal:
  "ln.  thr s t = Some (x, ln);
     ln = no_wait_locks;
     t  (x, shr s) -ta x'm';
     actions_ok s t ta 
   t  active_threads s"
| acquire: 
  "ln.  thr s t = Some (x, ln);
     ln  no_wait_locks;
     ¬ waiting (wset s t);
     may_acquire_all (locks s) t ln 
   t  active_threads s"

lemma active_threads_iff:
  "active_threads s = 
  {t. x ln. thr s t = Some (x, ln) 
             (if ln = no_wait_locks 
              then ta x' m'. t  (x, shr s) -ta (x', m')  actions_ok s t ta
              else ¬ waiting (wset s t)  may_acquire_all (locks s) t ln)}"
apply(auto elim!: active_threads.cases intro: active_threads.intros)
apply blast
done

lemma active_thread_ex_red:
  assumes "t  active_threads s"
  shows "ta s'. s -tta s'"
using assms
proof cases
  case (normal x ta x'm' ln)
  with redT_updWs_total[of t "wset s" "taw"]
  show ?thesis
    by(cases x'm')(fastforce intro!: redT_normal simp del: split_paired_Ex)
next
  case acquire thus ?thesis
    by(fastforce intro: redT_acquire simp del: split_paired_Ex simp add: neq_no_wait_locks_conv)
qed

end

text ‹Well-formedness conditions for final›

context final_thread begin

inductive not_final_thread :: "('l,'t,'x,'m,'w) state  't  bool"
for s :: "('l,'t,'x,'m,'w) state" and t :: "'t" where
  not_final_thread_final: "ln.  thr s t = (x, ln); ¬ final x   not_final_thread s t"
| not_final_thread_wait_locks: "ln.  thr s t = (x, ln); ln  no_wait_locks   not_final_thread s t"
| not_final_thread_wait_set: "ln.  thr s t = (x, ln); wset s t = w   not_final_thread s t"


declare not_final_thread.cases [elim]

lemmas not_final_thread_cases = not_final_thread.cases [consumes 1, case_names final wait_locks wait_set]

lemma not_final_thread_cases2 [consumes 2, case_names final wait_locks wait_set]:
  "ln.  not_final_thread s t; thr s t = (x, ln);
     ¬ final x  thesis; ln  no_wait_locks  thesis; w. wset s t = w  thesis 
   thesis"
by(auto)

lemma not_final_thread_iff:
  "not_final_thread s t  (x ln. thr s t = (x, ln)  (¬ final x  ln  no_wait_locks  (w. wset s t = w)))"
by(auto intro: not_final_thread.intros)

lemma not_final_thread_conv:
  "not_final_thread s t  thr s t  None  ¬ final_thread s t"
by(auto simp add: final_thread_def intro: not_final_thread.intros)

lemma not_final_thread_existsE:
  assumes "not_final_thread s t"
  and "x ln. thr s t = (x, ln)  thesis"
  shows thesis
using assms by blast

lemma not_final_thread_final_thread_conv:
  "thr s t  None  ¬ final_thread s t  not_final_thread s t"
by(simp add: not_final_thread_iff final_thread_def)

lemma may_join_cond_action_oks:
  assumes "t'. Join t'  set cas  ¬ not_final_thread s t'  t  t'"
  shows "cond_action_oks s t cas"
using assms
proof (induct cas)
  case Nil thus ?case by clarsimp
next
  case (Cons ca cas)
  note IH =  t'. Join t'  set cas  ¬ not_final_thread s t'  t  t' 
              cond_action_oks s t cas
  note ass = t'. Join t'  set (ca # cas)  ¬ not_final_thread s t'  t  t'
  hence "t'. Join t'  set cas  ¬ not_final_thread s t'  t  t'" by simp
  hence "cond_action_oks s t cas" by(rule IH)
  moreover have "cond_action_ok s t ca"
  proof(cases ca)
    case (Join t')
    with ass have "¬ not_final_thread s t'" "t  t'" by auto
    thus ?thesis using Join by(auto simp add: not_final_thread_iff)
  next
    case Yield thus ?thesis by simp
  qed
  ultimately show ?case by simp
qed

end

context multithreaded begin

lemma red_not_final_thread:
  "s -tta s'  not_final_thread s t"
by(fastforce elim: redT.cases intro: not_final_thread.intros dest: final_no_red)

lemma redT_preserves_final_thread:
  " s -t'ta s'; final_thread s t   final_thread s' t"
apply(erule redT.cases)
 apply(clarsimp simp add: final_thread_def)
apply(auto simp add: final_thread_def dest: redT_updTs_None redT_updTs_Some final_no_red intro: redT_updWs_None_implies_None)
done

end

context multithreaded_base begin

definition wset_Suspend_ok :: "('l,'t,'x,'m,'w) state set  ('l,'t,'x,'m,'w) state set"
where
  "wset_Suspend_ok I = 
  {s. s  I  
      (t  dom (wset s). s0I. s1I. ttas x x0 ta w' ln' ln''. s0 -tta s1  s1 -▹ttas→* s  
           thr s0 t = (x0, no_wait_locks)  t  x0, shr s0 -ta x, shr s1  Suspend w'  set taw 
           actions_ok s0 t ta  thr s1 t = (x, ln')  thr s t = (x, ln''))}"

lemma wset_Suspend_okI:
  " s  I;
     t w. wset s t = w  s0I. s1I. ttas x x0 ta w' ln' ln''. s0 -tta s1  s1 -▹ttas→* s  
           thr s0 t = (x0, no_wait_locks)  t  x0, shr s0 -ta x, shr s1  Suspend w'  set taw 
           actions_ok s0 t ta  thr s1 t = (x, ln')  thr s t = (x, ln'') 
   s  wset_Suspend_ok I"
unfolding wset_Suspend_ok_def by blast

lemma wset_Suspend_okD1:
  "s  wset_Suspend_ok I  s  I"
unfolding wset_Suspend_ok_def by blast

lemma wset_Suspend_okD2:
  " s  wset_Suspend_ok I; wset s t = w 
   s0I. s1I. ttas x x0 ta w' ln' ln''. s0 -tta s1  s1 -▹ttas→* s  
            thr s0 t = (x0, no_wait_locks)  t  x0, shr s0 -ta x, shr s1  Suspend w'  set taw 
            actions_ok s0 t ta  thr s1 t = (x, ln')  thr s t = (x, ln'')"
unfolding wset_Suspend_ok_def by blast

lemma wset_Suspend_ok_imp_wset_thread_ok:
  "s  wset_Suspend_ok I  wset_thread_ok (wset s) (thr s)"
apply(rule wset_thread_okI)
apply(rule ccontr)
apply(auto dest: wset_Suspend_okD2)
done

lemma invariant3p_wset_Suspend_ok:
  assumes I: "invariant3p redT I"
  shows "invariant3p redT (wset_Suspend_ok I)"
proof(rule invariant3pI)
  fix s tl s'
  assume wso: "s  wset_Suspend_ok I" 
    and "redT s tl s'"
  moreover obtain t' ta where tl: "tl = (t', ta)" by(cases tl)
  ultimately have red: "s -t'ta s'" by simp 
  moreover from wso have "s  I" by(rule wset_Suspend_okD1)
  ultimately have "s'  I" by(rule invariant3pD[OF I])
  thus "s'  wset_Suspend_ok I"
  proof(rule wset_Suspend_okI)
    fix t w
    assume ws't: "wset s' t = w"
    show "s0I. s1I. ttas x x0 ta w' ln' ln''. s0 -tta s1  s1 -▹ttas→* s' 
                   thr s0 t = (x0, no_wait_locks)  t  x0, shr s0 -ta x, shr s1 
                   Suspend w'  set taw  actions_ok s0 t ta 
                   thr s1 t = (x, ln')  thr s' t = (x, ln'')"
    proof(cases "t = t'")
      case False
      with red ws't obtain w' where wst: "wset s t = w'"
        by cases(auto 4 4 dest: redT_updWs_Some_otherD split: wait_set_status.split_asm)
      from wset_Suspend_okD2[OF wso this] obtain s0 s1 ttas x x0 ta' w' ln' ln''
        where reuse: "s0  I" "s1  I" "s0 -tta' s1" "thr s0 t = (x0, no_wait_locks)"
          "t  x0, shr s0 -ta' x, shr s1" "Suspend w'  set ta'w" "actions_ok s0 t ta'" "thr s1 t = (x, ln')"
        and step: "s1 -▹ttas→* s" and tst: "thr s t = (x, ln'')" by blast
      from step red have "s1 -▹ttas@[(t', ta)]→* s'" unfolding RedT_def by(rule rtrancl3p_step)
      moreover from red tst False have "thr s' t = (x, ln'')"
        by(cases)(auto intro: redT_updTs_Some)
      ultimately show ?thesis using reuse by blast
    next
      case True
      from red show ?thesis
      proof(cases)
        case (redT_normal x x' m)
        note red' = t'  x, shr s -ta x', m
          and tst' = ‹thr s t' = (x, no_wait_locks)
          and aok = ‹actions_ok s t' ta
          and s' = ‹redT_upd s t' ta x' m s'
        from s' have ws': "redT_updWs t' (wset s) taw (wset s')"
          and m: "m = shr s'" 
          and ts't: "thr s' t' = (x', redT_updLns (locks s) t' (snd (the (thr s t'))) tal)" by auto
        from aok have nwait: "¬ waiting (wset s t')"
          by(auto simp add: wset_actions_ok_def waiting_def split: if_split_asm)
        have "w'. Suspend w'  set taw"
        proof(cases "wset s t")
          case None
          from redT_updWs_None_SomeD[OF ws', OF ws't None] 
          show ?thesis ..
        next
          case (Some w')
          with True aok have "Notified  set taw  WokenUp  set taw"
            by(auto simp add: wset_actions_ok_def split: if_split_asm)
          with ws' show ?thesis using ws't unfolding True
            by(rule redT_updWs_WokenUp_SuspendD)
        qed
        with tst' ts't aok s  I s'  I red red' show ?thesis 
          unfolding True m by blast
      next
        case (redT_acquire x n ln) 
        with ws't True have "wset s t = w" by auto
        from wset_Suspend_okD2[OF wso this] ‹thr s t' = (x, ln) True
        obtain s0 s1 ttas x0 ta' w' ln' ln''
          where reuse: "s0  I" "s1  I" "s0 -tta' s1" "thr s0 t = (x0, no_wait_locks)"
            "t  x0, shr s0 -ta' x, shr s1" "Suspend w'  set ta'w" "actions_ok s0 t ta'" "thr s1 t = (x, ln')"
          and step: "s1 -▹ttas→* s" by fastforce
        from step red have "s1 -▹ttas@[(t', ta)]→* s'" unfolding RedT_def by(rule rtrancl3p_step)
        moreover from redT_acquire True have "thr s' t = (x, no_wait_locks)" by simp
        ultimately show ?thesis using reuse by blast
      qed
    qed
  qed
qed

end

end

Theory FWDeadlock

(*  Title:      JinjaThreads/Framework/FWDeadlock.thy
    Author:     Andreas Lochbihler
*)

section ‹Deadlock formalisation›

theory FWDeadlock
imports
  FWProgressAux
begin

context final_thread begin

definition all_final_except :: "('l,'t,'x,'m,'w) state  't set  bool" where
  "all_final_except s Ts  t. not_final_thread s t  t  Ts"

lemma all_final_except_mono [mono]:
  "(x. x  A  x  B)  all_final_except ts A  all_final_except ts B"
by(auto simp add: all_final_except_def)

lemma all_final_except_mono':
  " all_final_except ts A; x. x  A  x  B   all_final_except ts B"
by(blast intro: all_final_except_mono[rule_format])

lemma all_final_exceptI:
  "(t. not_final_thread s t  t  Ts)  all_final_except s Ts"
by(auto simp add: all_final_except_def)

lemma all_final_exceptD:
  " all_final_except s Ts; not_final_thread s t   t  Ts"
by(auto simp add: all_final_except_def)


inductive must_wait :: "('l,'t,'x,'m,'w) state  't  ('l + 't + 't)  't set  bool"
  for s :: "('l,'t,'x,'m,'w) state" and t :: "'t" where
  ― ‹Lock l›
  " has_lock (locks s $ l) t'; t'  t; t'  Ts   must_wait s t (Inl l) Ts"
| ― ‹Join t'›
  " not_final_thread s t'; t'  Ts   must_wait s t (Inr (Inl t')) Ts"
| ― ‹IsInterrupted t' True›
  " all_final_except s Ts; t'  interrupts s   must_wait s t (Inr (Inr t')) Ts"

declare must_wait.cases [elim]
declare must_wait.intros [intro]

lemma must_wait_elims [consumes 1, case_names lock join interrupt, cases pred]:
  assumes "must_wait s t lt Ts"
  obtains l t' where "lt = Inl l" "has_lock (locks s $ l) t'" "t'  t" "t'  Ts"
  | t' where "lt = Inr (Inl t')" "not_final_thread s t'" "t'  Ts"
  | t' where "lt = Inr (Inr t')" "all_final_except s Ts" "t'  interrupts s"
using assms
by(auto)

inductive_cases must_wait_elims2 [elim!]:
  "must_wait s t (Inl l) Ts"
  "must_wait s t (Inr (Inl t'')) Ts"
  "must_wait s t (Inr (Inr t'')) Ts"

lemma must_wait_iff:
  "must_wait s t lt Ts  
  (case lt of Inl l  t'Ts. t  t'  has_lock (locks s $ l) t'
     | Inr (Inl t')  not_final_thread s t'  t'  Ts
     | Inr (Inr t')  all_final_except s Ts  t'  interrupts s)"
by(auto simp add: must_wait.simps split: sum.splits)

end

text‹Deadlock as a system-wide property›

context multithreaded_base begin

definition
  deadlock :: "('l,'t,'x,'m,'w) state  bool"
where
  "deadlock s
      (t x. thr s t = (x, no_wait_locks)  ¬ final x  wset s t = None
         t  x, shr s   (LT. t  x, shr s LT   (lt  LT. must_wait s t lt (dom (thr s)))))
      (t x ln. thr s t = (x, ln)  (l. ln $ l > 0)  ¬ waiting (wset s t)
         (l t'. ln $ l > 0  t  t'  thr s t'  None  has_lock (locks s $ l) t'))
      (t x w. thr s t = (x, no_wait_locks)  wset s t  PostWS w)"

lemma deadlockI:
  " t x.  thr s t = (x, no_wait_locks); ¬ final x; wset s t = None 
     t  x, shr s   (LT. t  x, shr s LT   (lt  LT. must_wait s t lt (dom (thr s))));
    t x ln l.  thr s t = (x, ln); ln $ l > 0; ¬ waiting (wset s t) 
     l t'. ln $ l > 0  t  t'  thr s t'  None  has_lock (locks s $ l) t';
    t x w. thr s t = (x, no_wait_locks)  wset s t  PostWS w 
   deadlock s"
by(auto simp add: deadlock_def)

lemma deadlockE:
  assumes "deadlock s"
  obtains "t x. thr s t = (x, no_wait_locks)  ¬ final x  wset s t = None
         t  x, shr s   (LT. t  x, shr s LT   (lt  LT. must_wait s t lt (dom (thr s))))"
  and "t x ln. thr s t = (x, ln)  (l. ln $ l > 0)  ¬ waiting (wset s t)
                 (l t'. ln $ l > 0  t  t'  thr s t'  None  has_lock (locks s $ l) t')"
  and "t x w. thr s t = (x, no_wait_locks)  wset s t  PostWS w"
using assms unfolding deadlock_def by(blast)

lemma deadlockD1:
  assumes "deadlock s"
  and "thr s t = (x, no_wait_locks)"
  and "¬ final x"
  and "wset s t = None"
  obtains "t  x, shr s "
  and "LT. t  x, shr s LT   (lt  LT. must_wait s t lt (dom (thr s)))"
using assms unfolding deadlock_def by(blast)

lemma deadlockD2:
  fixes ln
  assumes "deadlock s"
  and "thr s t = (x, ln)"
  and "ln $ l > 0"
  and "¬ waiting (wset s t)"
  obtains l' t' where "ln $ l' > 0" "t  t'" "thr s t'  None" "has_lock (locks s $ l') t'"
using assms unfolding deadlock_def by blast

lemma deadlockD3:
  assumes "deadlock s"
  and "thr s t = (x, no_wait_locks)"
  shows "w. wset s t  PostWS w"
using assms unfolding deadlock_def by blast

lemma deadlock_def2:
  "deadlock s 
    (t x. thr s t = (x, no_wait_locks)  ¬ final x  wset s t = None
     t  x, shr s   (LT. t  x, shr s LT   (lt  LT. must_wait s t lt (dom (thr s)))))
   (t x ln. thr s t = (x, ln)  ln  no_wait_locks  ¬ waiting (wset s t)
     (l. ln $ l > 0  must_wait s t (Inl l) (dom (thr s))))
   (t x w. thr s t = (x, no_wait_locks)  wset s t  PostWS WSNotified  wset s t  PostWS WSWokenUp)"
unfolding neq_no_wait_locks_conv
apply(rule iffI)
 apply(intro strip conjI)
     apply(blast dest: deadlockD1)
    apply(blast dest: deadlockD1)
   apply(blast elim: deadlockD2)
  apply(blast dest: deadlockD3)
 apply(blast dest: deadlockD3)
apply(elim conjE exE)
apply(rule deadlockI)
  apply blast
 apply(rotate_tac 1)
 apply(erule allE, rotate_tac -1)
 apply(erule allE, rotate_tac -1)
 apply(erule allE, rotate_tac -1)
 apply(erule impE, blast)
 apply(elim exE conjE)
 apply(erule must_wait.cases)
   apply(clarify)
   apply(rotate_tac 3)
   apply(rule exI conjI|erule not_sym|assumption)+
    apply blast
   apply blast
  apply blast
 apply blast
apply(case_tac w)
 apply blast
apply blast
done

lemma all_waiting_implies_deadlock:
  assumes "lock_thread_ok (locks s) (thr s)"
  and normal: "t x.  thr s t = (x, no_wait_locks); ¬ final x; wset s t = None  
                t  x, shr s   (LT. t  x, shr s LT   (lt  LT. must_wait s t lt (dom (thr s))))"
  and acquire: "t x ln l.  thr s t = (x, ln); ¬ waiting (wset s t); ln $ l > 0 
                  l'. ln $ l' > 0  ¬ may_lock (locks s $ l') t"
  and wakeup: "t x w. thr s t = (x, no_wait_locks)  wset s t  PostWS w"
  shows "deadlock s"
proof(rule deadlockI)
  fix T X
  assume "thr s T = (X, no_wait_locks)" "¬ final X" "wset s T = None"
  thus "T  X, shr s   (LT. T  X, shr s LT   (ltLT. must_wait s T lt (dom (thr s))))" 
    by(rule normal)
next
  fix T X LN l'
  assume "thr s T = (X, LN)"
    and "0 < LN $ l'"
    and wset: "¬ waiting (wset s T)"
  from acquire[OF ‹thr s T = (X, LN) wset, OF 0 < LN $ l']
  obtain l' where "0 < LN $ l'" "¬ may_lock (locks s $ l') T" by blast
  then obtain t' where "T  t'" "has_lock (locks s $ l') t'"
    unfolding not_may_lock_conv by fastforce
  moreover with ‹lock_thread_ok (locks s) (thr s)
  have "thr s t'  None" by(auto dest: lock_thread_okD)
  ultimately show "l t'. 0 < LN $ l  T  t'  thr s t'  None  has_lock (locks s $ l) t'"
    using 0 < LN $ l' by(auto)
qed(rule wakeup)

lemma mfinal_deadlock:
  "mfinal s  deadlock s"
unfolding mfinal_def2
by(rule deadlockI)(auto simp add: final_thread_def)

text ‹Now deadlock for single threads›

lemma must_wait_mono:
  "(x. x  A  x  B)  must_wait s t lt A  must_wait s t lt B"
by(auto simp add: must_wait_iff split: sum.split elim: all_final_except_mono')

lemma must_wait_mono':
  " must_wait s t lt A; A  B   must_wait s t lt B"
using must_wait_mono[of A B s t lt]
by blast

end

lemma UN_mono: " x  A  x  A'; x  B  x  B'   x  A  B  x  A'  B'"
by blast

lemma Collect_mono_conv [mono]: "x  {x. P x}  P x"
by blast

context multithreaded_base begin

coinductive_set deadlocked :: "('l,'t,'x,'m,'w) state  't set"
  for s :: "('l,'t,'x,'m,'w) state" where
  deadlockedLock:
    " thr s t = (x, no_wait_locks); t  x, shr s ; wset s t = None;
       LT. t  x, shr s LT   lt  LT. must_wait s t lt (deadlocked s  final_threads s) 
      t  deadlocked s"

| deadlockedWait:
    "ln.  thr s t = (x, ln); all_final_except s (deadlocked s); waiting (wset s t)   t  deadlocked s"

| deadlockedAcquire:
    "ln.  thr s t = (x, ln); ¬ waiting (wset s t); ln $ l > 0; has_lock (locks s $ l) t'; t'  t; 
       t'  deadlocked s  final_thread s t'  
      t  deadlocked s"
monos must_wait_mono UN_mono

lemma deadlockedAcquire_must_wait:
  "ln.  thr s t = (x, ln); ¬ waiting (wset s t); ln $ l > 0; must_wait s t (Inl l) (deadlocked s  final_threads s) 
   t  deadlocked s"
apply(erule must_wait_elims)
apply(erule (2) deadlockedAcquire)
apply auto
done

lemma deadlocked_elims [consumes 1, case_names lock wait acquire]:
  assumes "t  deadlocked s"
  and lock: "x.  thr s t = (x, no_wait_locks); t  x, shr s ; wset s t = None;
     LT. t  x, shr s LT   lt  LT. must_wait s t lt (deadlocked s  final_threads s) 
      thesis"
  and wait: "x ln.  thr s t = (x, ln); all_final_except s (deadlocked s); waiting (wset s t) 
      thesis"
  and acquire: "x ln l t'. 
     thr s t = (x, ln); ¬ waiting (wset s t); 0 < ln $ l; has_lock (locks s $ l) t'; t  t';
      t'  deadlocked s  final_thread s t'   thesis"
  shows thesis
using assms by cases blast+

lemma deadlocked_coinduct 
  [consumes 1, case_names deadlocked, case_conclusion deadlocked Lock Wait Acquire, coinduct set: deadlocked]:
  assumes major: "t  X"
  and step: 
  "t. t  X 
     (x. thr s t = (x, no_wait_locks)  t  x, shr s   wset s t = None 
         (LT. t  x, shr s LT   (ltLT. must_wait s t lt (X  deadlocked s  final_threads s)))) 
     (x ln. thr s t = (x, ln)  all_final_except s (X  deadlocked s)  waiting (wset s t)) 
     (x l t' ln. thr s t = (x, ln)  ¬ waiting (wset s t)  0 < ln $ l  has_lock (locks s $ l) t' 
         t'  t  ((t'  X  t'  deadlocked s)  final_thread s t'))"
  shows "t  deadlocked s"
using major
proof(coinduct)
  case (deadlocked t)
  have "X  deadlocked s  final_threads s = {x. x  X  x  deadlocked s  x  final_threads s}"
    by auto
  moreover have "X  deadlocked s = {x. x  X  x  deadlocked s}" by blast
  ultimately show ?case using step[OF deadlocked] by(elim disjE) simp_all
qed

definition deadlocked' :: "('l,'t,'x,'m,'w) state  bool" where
  "deadlocked' s  (t. not_final_thread s t  t  deadlocked s)"

lemma deadlocked'I:
  "(t. not_final_thread s t  t  deadlocked s)  deadlocked' s"
by(auto simp add: deadlocked'_def)

lemma deadlocked'D2:
  " deadlocked' s; not_final_thread s t; t  deadlocked s  thesis   thesis"
by(auto simp add: deadlocked'_def)

lemma not_deadlocked'I:
  " not_final_thread s t; t  deadlocked s   ¬ deadlocked' s"
by(auto dest: deadlocked'D2)

lemma deadlocked'_intro:
  " t. not_final_thread s t  t  deadlocked s   deadlocked' s"
by(rule deadlocked'I)(blast)+

lemma deadlocked_thread_exists: 
  assumes "t  deadlocked s"
  and "x ln. thr s t = (x, ln)  thesis"
  shows thesis
using assms
by cases blast+

end

context multithreaded begin 

lemma red_no_deadlock: 
  assumes P: "s -tta s'"
  and dead: "t  deadlocked s"
  shows False
proof -
  from P show False
  proof(cases)
    case (redT_normal x x' m')
    note red = t  x, shr s -ta x', m'
    note tst = ‹thr s t = (x, no_wait_locks)
    note aok = ‹actions_ok s t ta
    show False
    proof(cases "w. wset s t = InWS w")
      case True with aok show ?thesis by(auto simp add: wset_actions_ok_def split: if_split_asm)
    next
      case False
      with dead tst
      have mle: "t  x, shr s "
        and cledead: "LT. t  x, shr s LT   (lt  LT. must_wait s t lt (deadlocked s  final_threads s))"
        by(cases, auto simp add: waiting_def)+
      let ?LT = "collect_waits ta"
      from red have "t  x, shr s ?LT " by(auto intro: can_syncI)
      then obtain lt where lt: "lt  ?LT" and mw: "must_wait s t lt (deadlocked s  final_threads s)"
        by(blast dest: cledead[rule_format])
      from mw show False
      proof(cases rule: must_wait_elims)
        case (lock l t')
        from lt = Inl l lt have "l  collect_locks tal" by(auto)
        with aok have "may_lock (locks s $ l) t"
          by(auto elim!: collect_locksE lock_ok_las_may_lock)
        with ‹has_lock (locks s $ l) t' have "t' = t"
          by(auto dest: has_lock_may_lock_t_eq)
        with t'  t show False by contradiction
      next
        case (join t')
        from lt = Inr (Inl t') lt have "Join t'  set tac" by auto
        from ‹not_final_thread s t'  obtain x'' ln''
          where "thr s t' = (x'', ln'')" by(rule not_final_thread_existsE)
        moreover with ‹Join t'  set tac aok
        have "final x''" "ln'' = no_wait_locks" "wset s t' = None"
          by(auto dest: cond_action_oks_Join)
        ultimately show False using ‹not_final_thread s t' by(auto)
      next
        case (interrupt t')
        from  aok lt lt = Inr (Inr t')
        have "t'  interrupts s"
          by(auto intro: collect_interrupts_interrupted)
        with t'  interrupts s show False by contradiction
      qed
    qed
  next
    case (redT_acquire x n ln)
    show False
    proof(cases "w. wset s t = InWS w")
      case True with ¬ waiting (wset s t) show ?thesis
        by(auto simp add: not_waiting_iff)
    next
      case False
      with dead ‹thr s t = (x, ln) 0 < ln $ n
      obtain l t' where "0 < ln $ l" "t  t'"
        and "has_lock (locks s $ l) t'"
        by(cases)(fastforce simp add: waiting_def)+
      hence "¬ may_acquire_all (locks s) t ln"
        by(auto elim: may_acquire_allE dest: has_lock_may_lock_t_eq)
      with ‹may_acquire_all (locks s) t ln show ?thesis by contradiction
    qed
  qed
qed

lemma deadlocked'_no_red:
  " s -tta s'; deadlocked' s   False"
apply(rule red_no_deadlock)
 apply(assumption)
apply(erule deadlocked'D2)
by(rule red_not_final_thread)

lemma not_final_thread_deadlocked_final_thread [iff]: 
  "thr s t = xln  not_final_thread s t  t  deadlocked s  final_thread s t"
by(auto simp add: not_final_thread_final_thread_conv[symmetric])

lemma all_waiting_deadlocked:
  assumes "not_final_thread s t"
  and "lock_thread_ok (locks s) (thr s)" 
  and normal: "t x.  thr s t = (x, no_wait_locks); ¬ final x; wset s t = None  
                t  x, shr s   (LT. t  x, shr s LT   (ltLT. must_wait s t lt (final_threads s)))"
  and acquire: "t x ln l.  thr s t = (x, ln); ¬ waiting (wset s t); ln $ l > 0 
                 l'. ln $ l' > 0  ¬ may_lock (locks s $ l') t"
  and wakeup: "t x w. thr s t = (x, no_wait_locks)  wset s t  PostWS w"
  shows "t  deadlocked s"
proof -
  from ‹not_final_thread s t
  have "t  {t. not_final_thread s t}" by simp
  thus ?thesis
  proof(coinduct)
    case (deadlocked z)
    hence "not_final_thread s z" by simp
    then obtain x' ln' where "thr s z = (x', ln')" by(fastforce elim!: not_final_thread_existsE)
    {
      assume "wset s z = None" "¬ final x'"
        and [simp]: "ln' = no_wait_locks"
      with ‹thr s z = (x', ln')
      have "z  x', shr s   (LT. z  x', shr s LT   (lt  LT. must_wait s z lt (final_threads s)))"
        by(auto dest: normal)
      then obtain "z  x', shr s "
        and clnml: "LT. z  x', shr s LT   lt  LT. must_wait s z lt (final_threads s)" by(blast)
      { fix LT
        assume "z  x', shr s LT "
        then obtain lt where mw: "must_wait s z lt (final_threads s)" and lt: "lt  LT"
          by(blast dest: clnml)
        from mw have "must_wait s z lt ({t. not_final_thread s t}  deadlocked s  final_threads s)"
          by(blast intro: must_wait_mono')
        with lt have "lt  LT. must_wait s z lt ({t. not_final_thread s t}  deadlocked s  final_threads s)"
          by blast }
      with z  x', shr s  ‹thr s z = (x', ln') ‹wset s z = None› have ?case by(simp) }
    note c1 = this
    { 
      assume wsz: "¬ waiting (wset s z)"
        and "ln'  no_wait_locks"
      from ln'  no_wait_locks› obtain l where "0 < ln' $ l"
        by(auto simp add: neq_no_wait_locks_conv)
      with wsz ‹thr s z = (x', ln') 
      obtain l' where "0 < ln' $ l'" "¬ may_lock (locks s $ l') z"
        by(blast dest: acquire)
      then obtain t'' where "t''  z" "has_lock (locks s $ l') t''"
        unfolding not_may_lock_conv by blast
      with ‹lock_thread_ok (locks s) (thr s)
      obtain x'' ln'' where "thr s t'' = (x'', ln'')"
        by(auto elim!: lock_thread_ok_has_lockE)
      hence "(not_final_thread s t''  t''  deadlocked s)  final_thread s t''"
        by(clarsimp simp add: not_final_thread_iff final_thread_def)
      with wsz 0 < ln' $ l' ‹thr s z = (x', ln') t''  z ‹has_lock (locks s $ l') t''
      have ?Acquire by simp blast
      hence ?case by simp }
    note c2 = this
    { fix w
      assume "waiting (wset s z)"
      with ‹thr s z = (x', ln')
      have "?Wait" by(clarsimp simp add: all_final_except_def)
      hence ?case by simp }
    note c3 = this
    from ‹not_final_thread s z ‹thr s z = (x', ln') show ?case
    proof(cases rule: not_final_thread_cases2)
      case final show ?thesis
      proof(cases "wset s z")
        case None show ?thesis
        proof(cases "ln' = no_wait_locks")
          case True with None final show ?thesis by(rule c1)
        next
          case False
          from None have "¬ waiting (wset s z)" by(simp add: not_waiting_iff)
          thus ?thesis using False by(rule c2)
        qed
      next
        case (Some w)
        show ?thesis
        proof(cases w)
          case (InWS w') 
          with Some have "waiting (wset s z)" by(simp add: waiting_def)
          thus ?thesis by(rule c3)
        next
          case (PostWS w')
          with Some have "¬ waiting (wset s z)" by(simp add: not_waiting_iff)
          moreover from PostWS ‹thr s z = (x', ln') Some
          have "ln'  no_wait_locks" by(auto dest: wakeup)
          ultimately show ?thesis by(rule c2)
        qed
      qed
    next
      case wait_locks show ?thesis
      proof(cases "wset s z")
        case None
        hence "¬ waiting (wset s z)" by(simp add: not_waiting_iff)
        thus ?thesis using wait_locks by(rule c2)
      next
        case (Some w)
        show ?thesis
        proof(cases w)
          case (InWS w')
          with Some have "waiting (wset s z)" by(simp add: waiting_def)
          thus ?thesis by(rule c3)
        next
          case (PostWS w')
          with Some have "¬ waiting (wset s z)" by(simp add: not_waiting_iff)
          moreover from PostWS ‹thr s z = (x', ln') Some
          have "ln'  no_wait_locks" by(auto dest: wakeup)
          ultimately show ?thesis by(rule c2)
        qed
      qed
    next
      case (wait_set w)
      show ?thesis
      proof(cases w)
        case (InWS w')
        with wait_set have "waiting (wset s z)" by(simp add: waiting_def)
        thus ?thesis by(rule c3)
      next
        case (PostWS w')
        with wait_set have "¬ waiting (wset s z)" by(simp add: not_waiting_iff)
        moreover from PostWS ‹thr s z = (x', ln') wait_set
        have "ln'  no_wait_locks" by(auto dest: wakeup[simplified])
        ultimately show ?thesis by(rule c2)
      qed
    qed
  qed
qed

text ‹Equivalence proof for both notions of deadlock›

lemma deadlock_implies_deadlocked':
  assumes dead: "deadlock s" 
  shows "deadlocked' s"
proof -
  show ?thesis
  proof(rule deadlocked'I)
    fix t
    assume "not_final_thread s t"
    hence "t  {t. not_final_thread s t}" ..
    thus "t  deadlocked s"
    proof(coinduct)
      case (deadlocked t'')
      hence "not_final_thread s t''" ..
      then obtain x'' ln'' where tst'': "thr s t'' = (x'', ln'')"
        by(rule not_final_thread_existsE)
      { assume "waiting (wset s t'')"
        moreover
        with tst'' have nfine: "not_final_thread s t''"
          unfolding waiting_def
          by(blast intro: not_final_thread.intros)
        ultimately have ?case using tst''
          by(blast intro: all_final_exceptI not_final_thread_final) }
      note c1 = this
      { 
        assume wst'': "¬ waiting (wset s t'')"
          and "ln''  no_wait_locks"
        then obtain l where l: "ln'' $ l > 0"
          by(auto simp add: neq_no_wait_locks_conv)
        with dead wst'' tst'' obtain l' T
          where "ln'' $ l' > 0" "t''  T" 
          and hl: "has_lock (locks s $ l') T"
          and tsT: "thr s T  None"
          by - (erule deadlockD2)
        moreover from ‹thr s T  None›
        obtain xln where tsT: "thr s T = xln" by auto
        then obtain X LN where "thr s T = (X, LN)"
          by(cases xln, auto)
        moreover hence "not_final_thread s T  final_thread s T"
          by(auto simp add: final_thread_def not_final_thread_iff)
        ultimately have ?case using wst'' tst'' by blast }
      note c2 = this
      { assume "wset s t'' = None"
        and [simp]: "ln'' = no_wait_locks"
        moreover
        with ‹not_final_thread s t'' tst''
        have "¬ final x''" by(auto)
        ultimately obtain "t''  x'', shr s "
          and clnml: "LT. t''  x'', shr s LT   t'. thr s t'  None  (ltLT. must_wait s t'' lt (dom (thr s)))"
          using ‹thr s t'' = (x'', ln'') ‹deadlock s
          by(blast elim: deadlockD1)
        { fix LT
          assume "t''  x'', shr s LT "
          then obtain lt where lt: "lt  LT"
            and mw: "must_wait s t'' lt (dom (thr s))"
            by(blast dest: clnml)
          note mw
          also have "dom (thr s) = {t. not_final_thread s t}  deadlocked s  final_threads s"
            by(auto simp add: not_final_thread_conv dest: deadlocked_thread_exists elim: final_threadE)
          finally have "ltLT. must_wait s t'' lt ({t. not_final_thread s t}  deadlocked s  final_threads s)"
            using lt by blast }
        with t''  x'', shr s  tst'' ‹wset s t'' = None› have ?case by(simp) }
      note c3 = this
      from ‹not_final_thread s t'' tst'' show ?case
      proof(cases rule: not_final_thread_cases2)
        case final show ?thesis
        proof(cases "wset s t''")
          case None show ?thesis
          proof(cases "ln'' = no_wait_locks")
            case True with None show ?thesis by(rule c3)
          next
            case False
            from None have "¬ waiting (wset s t'')" by(simp add: not_waiting_iff)
            thus ?thesis using False by(rule c2)
          qed
        next
          case (Some w)
          show ?thesis
          proof(cases w)
            case (InWS w')
            with Some have "waiting (wset s t'')" by(simp add: waiting_def)
            thus ?thesis by(rule c1)
          next
            case (PostWS w')
            hence "¬ waiting (wset s t'')" using Some by(simp add: not_waiting_iff)
            moreover from PostWS Some tst''
            have "ln''  no_wait_locks" by(auto dest: deadlockD3[OF dead])
            ultimately show ?thesis by(rule c2)
          qed            
        qed
      next
        case wait_locks show ?thesis
        proof(cases "waiting (wset s t'')")
          case False
          thus ?thesis using wait_locks by(rule c2)
        next
          case True thus ?thesis by(rule c1)
        qed
      next
        case (wait_set w)
        show ?thesis
        proof(cases w)
          case InWS
          with wait_set have "waiting (wset s t'')" by(simp add: waiting_def)
          thus ?thesis by(rule c1)
        next
          case (PostWS w')
          hence "¬ waiting (wset s t'')" using wait_set
            by(simp add: not_waiting_iff)
          moreover from PostWS wait_set tst''
          have "ln''  no_wait_locks" by(auto dest: deadlockD3[OF dead])
          ultimately show ?thesis by(rule c2)
        qed
      qed
    qed
  qed
qed

lemma deadlocked'_implies_deadlock:
  assumes dead: "deadlocked' s" 
  shows "deadlock s"
proof -
  have deadlocked: "t. not_final_thread s t  t  deadlocked s"
    using dead by(rule deadlocked'D2)
  show ?thesis
  proof(rule deadlockI)
    fix t' x'
    assume "thr s t' = (x', no_wait_locks)"
      and "¬ final x'"
      and "wset s t' = None"
    hence "not_final_thread s t'" by(auto intro: not_final_thread_final)
    hence "t'  deadlocked s" by(rule deadlocked)
    thus "t'  x', shr s   (LT. t'  x', shr s LT   (lt  LT. must_wait s t' lt (dom (thr s))))"
    proof(cases rule: deadlocked_elims)
      case (lock x'')
      note lock = LT. t'  x'', shr s LT   lt  LT. must_wait s t' lt (deadlocked s  final_threads s)
      from ‹thr s t' = (x'', no_wait_locks) ‹thr s t' = (x', no_wait_locks)
      have [simp]: "x' = x''" by auto
      { fix LT
        assume "t'  x'', shr s LT "
        from lock[OF this] obtain lt where lt: "lt  LT"
          and mw: "must_wait s t' lt (deadlocked s  final_threads s)" by blast
        have "deadlocked s  final_threads s  dom (thr s)"
          by(auto elim: final_threadE dest: deadlocked_thread_exists)
        with mw have "must_wait s t' lt (dom (thr s))" by(rule must_wait_mono')
        with lt have "ltLT. must_wait s t' lt (dom (thr s))" by blast }
      with t'  x'', shr s  show ?thesis by(auto)
    next
      case (wait x'' ln'')
      from ‹wset s t' = None› ‹waiting (wset s t')
      have False by(simp add: waiting_def)
      thus ?thesis ..
    next
      case (acquire x'' ln'' l'' T)
      from ‹thr s t' = (x'', ln'') ‹thr s t' = (x', no_wait_locks) 0 < ln'' $ l''
      have False by(auto)
      thus ?thesis ..
    qed
  next
    fix t' x' ln' l
    assume "thr s t' = (x', ln')"
      and "0 < ln' $ l"
      and wst': "¬ waiting (wset s t')"
    hence "not_final_thread s t'" by(auto intro: not_final_thread_wait_locks)
    hence "t'  deadlocked s" by(rule deadlocked)
    thus "l T. 0 < ln' $ l  t'  T  thr s T  None  has_lock (locks s $ l) T"
    proof(cases rule: deadlocked_elims)
      case (lock x'')
      from ‹thr s t' = (x', ln') ‹thr s t' = (x'', no_wait_locks) 0 < ln' $ l
      have False by auto
      thus ?thesis ..
    next
      case (wait x' ln')
      from wst' ‹waiting (wset s t')
      have False by contradiction
      thus ?thesis ..
    next
      case (acquire x'' ln'' l'' t'')
      from ‹thr s t' = (x'', ln'') ‹thr s t' = (x', ln')
      have [simp]: "x' = x''" "ln' = ln''" by auto
      moreover from t''  deadlocked s  final_thread s t''
      have "thr s t''  None"
        by(auto elim: deadlocked_thread_exists simp add: final_thread_def)
      with 0 < ln'' $ l'' ‹has_lock (locks s $ l'') t'' t'  t'' ‹thr s t' = (x'', ln'')
      show ?thesis by auto
    qed
  next
    fix t x w
    assume tst: "thr s t = (x, no_wait_locks)"
    show "wset s t  PostWS w"
    proof
      assume "wset s t = PostWS w"
      moreover with tst have "not_final_thread s t"
        by(auto simp add: not_final_thread_iff)
      hence "t  deadlocked s" by(rule deadlocked)
      ultimately show False using tst
        by(auto elim: deadlocked.cases simp add: waiting_def)
    qed
  qed
qed

lemma deadlock_eq_deadlocked':
  "deadlock = deadlocked'"
by(rule ext)(auto intro: deadlock_implies_deadlocked' deadlocked'_implies_deadlock)

lemma deadlock_no_red:
  " s -tta s'; deadlock s   False"
unfolding deadlock_eq_deadlocked'
by(rule deadlocked'_no_red)

lemma deadlock_no_active_threads:
  assumes dead: "deadlock s"
  shows "active_threads s = {}"
proof(rule equals0I)
  fix t
  assume active: "t  active_threads s"
  then obtain ta s' where "s -tta s'" by(auto dest: active_thread_ex_red)
  thus False using dead by(rule deadlock_no_red)
qed

end

locale preserve_deadlocked = multithreaded final r convert_RA 
  for final :: "'x  bool"
  and r :: "('l,'t,'x,'m,'w,'o) semantics" ("_  _ -_ _" [50,0,0,50] 80) 
  and convert_RA :: "'l released_locks  'o list"
  +
  fixes wf_state :: "('l,'t,'x,'m,'w) state set"
  assumes invariant3p_wf_state: "invariant3p redT wf_state"
  assumes can_lock_preserved: 
    " s  wf_state; s -t'ta' s';
       thr s t = (x, no_wait_locks); t  x, shr s  
     t  x, shr s' "
  and can_lock_devreserp:
    " s  wf_state; s -t'ta' s';
       thr s t = (x, no_wait_locks); t  x, shr s' L  
     L'L. t  x, shr s L' "
begin

lemma redT_deadlocked_subset:
  assumes wfs: "s  wf_state"
  and Red: "s -tta s'"
  shows "deadlocked s  deadlocked s'"
proof
  fix t'
  assume t'dead: "t'  deadlocked s"
  from Red have tndead: "t  deadlocked s"
    by(auto dest: red_no_deadlock)
  with t'dead have t't: "t'  t" by auto
  { fix t'
    assume "final_thread s t'"
    then obtain x' ln' where tst': "thr s t' = (x', ln')" by(auto elim!: final_threadE)
    with ‹final_thread s t' have "final x'" 
      and "wset s t' = None" and [simp]: "ln' = no_wait_locks"
      by(auto elim: final_threadE)
    with Red tst' have "t  t'" by cases(auto dest: final_no_red)
    with Red tst' have "thr s' t' = (x', ln')"
      by cases(auto intro: redT_updTs_Some)
    moreover from Red  t  t' ‹wset s t' = None›
    have "wset s' t' = None" by cases(auto simp: redT_updWs_None_implies_None)
    ultimately have "final_thread s' t'" using tst' final x'
      by(auto simp add: final_thread_def) }
  hence subset: "deadlocked s  final_threads s  deadlocked s  deadlocked s'  final_threads s'" by(auto)

  from Red show "t'  deadlocked s'"
  proof(cases)
    case (redT_normal x x' m')
    note red = t  x, shr s -ta x', m'
      and tst = ‹thr s t = (x, no_wait_locks)
      and aok = ‹actions_ok s t ta
      and s' = ‹redT_upd s t ta x' m' s'
    from red have "¬ final x" by(auto dest: final_no_red)
    with tndead tst have nafe: "¬ all_final_except s (deadlocked s)"
      by(fastforce simp add: all_final_except_def not_final_thread_iff)
    from t'dead show ?thesis
    proof(coinduct)
      case (deadlocked t'')
      note t''dead = this
      with Red have t''t: "t''  t"
        by(auto dest: red_no_deadlock)
      from t''dead show ?case
      proof(cases rule: deadlocked_elims)
        case (lock X)
        hence est'': "thr s t'' = (X, no_wait_locks)"
          and msE: "t''  X, shr s "
          and csexdead: "LT. t''  X, shr s LT   lt  LT. must_wait s t'' lt (deadlocked s  final_threads s)"
          by auto
        from t''t Red est''
        have es't'': "thr s' t'' = (X, no_wait_locks)"
          by(cases s)(cases s', auto elim!: redT_ts_Some_inv)
        note es't'' moreover
        from wfs Red est'' msE have msE': "t''  X, shr s' " by(rule can_lock_preserved)
        moreover
        { fix LT
          assume clL'': "t''  X, shr s' LT "
          with est'' have "LT'LT. t''  X, shr s LT' "
            by(rule can_lock_devreserp[OF wfs Red])
          then obtain LT' where clL': "t''  X, shr s LT' "
            and LL': "LT'  LT" by blast
          with csexdead obtain lt
            where lt: "lt  LT" and mw: "must_wait s t'' lt (deadlocked s  final_threads s)"
            by blast
          from mw have "must_wait s' t'' lt (deadlocked s  deadlocked s'  final_threads s')"
          proof(cases rule: must_wait_elims)
            case (lock l t')
            from t'  deadlocked s  final_threads s Red have tt': "t  t'"
              by(auto dest: red_no_deadlock final_no_redT elim: final_threadE)
            from aok have "lock_actions_ok (locks s $ l) t (tal $ l)"
              by(auto simp add: lock_ok_las_def)
            with tt' ‹has_lock (locks s $ l) t' s'
            have hl't': "has_lock (locks s' $ l) t'" by(auto)
            moreover note t'  t''
            moreover from t'  deadlocked s  final_threads s
            have "t'  (deadlocked s  deadlocked s'  final_threads s')"
              using subset by blast
            ultimately show ?thesis unfolding lt = Inl l ..
          next
            case (join t')
            note t'dead = t'  deadlocked s  final_threads s
            with Red have tt': "t  t'"
              by(auto dest: red_no_deadlock final_no_redT elim: final_threadE)
            note nftt' = ‹not_final_thread s t'
            from t'dead Red aok s' tt' have ts't': "thr s' t' = thr s t'"
              by(auto elim!: deadlocked_thread_exists final_threadE intro: redT_updTs_Some)
            from nftt' have "thr s t'  None" by auto
            with nftt' t'dead have "t'  deadlocked s"
              by(simp add: not_final_thread_final_thread_conv[symmetric])
            hence "not_final_thread s' t'"
            proof(cases rule: deadlocked_elims)
              case (lock x'')
              from t'  x'', shr s  have "¬ final x''"
                by(auto elim: must_syncE dest: final_no_red)
              with ‹thr s t' = (x'', no_wait_locks) ts't' show ?thesis
                by(auto intro: not_final_thread.intros)
            next
              case (wait x'' ln'')
              from ¬ final x tst ‹all_final_except s (deadlocked s)
              have "t  deadlocked s" by(fastforce dest: all_final_exceptD simp add: not_final_thread_iff)
              with Red have False by(auto dest: red_no_deadlock)
              thus ?thesis ..
            next
              case (acquire x'' ln'' l'' T'')
              from ‹thr s t' = (x'', ln'') 0 < ln'' $ l'' ts't'
              show ?thesis by(auto intro: not_final_thread.intros(2))
            qed
            moreover from t'dead subset have "t'  deadlocked s  deadlocked s'  final_threads s'" ..
            ultimately show ?thesis unfolding lt = Inr (Inl t') ..
          next
            case (interrupt t')
            from tst red aok have "not_final_thread s t"
              by(auto simp add: wset_actions_ok_def not_final_thread_iff split: if_split_asm dest: final_no_red)
            with ‹all_final_except s (deadlocked s  final_threads s)
            have "t  deadlocked s  final_threads s" by(rule all_final_exceptD)
            moreover have "t  deadlocked s" using Red by(blast dest: red_no_deadlock)
            moreover have "¬ final_thread s t" using red tst by(auto simp add: final_thread_def dest: final_no_red)
            ultimately have False by blast
            thus ?thesis ..
          qed
          with lt have "ltLT. must_wait s' t'' lt (deadlocked s  deadlocked s'  final_threads s')" by blast }
        moreover have "wset s' t'' = None" using s' t''t ‹wset s t'' = None› 
          by(auto intro: redT_updWs_None_implies_None)
        ultimately show ?thesis by(auto)
      next
        case (wait x ln)
        from ‹all_final_except s (deadlocked s) nafe have False by simp
        thus ?thesis by simp
      next
        case (acquire X ln l T)
        from t''t Red ‹thr s t'' = (X, ln) s'
        have es't'': "thr s' t'' = (X, ln)"
          by(cases s)(auto dest: redT_ts_Some_inv)
        moreover
        from T  deadlocked s  final_thread s T
        have "T  t"
        proof(rule disjE)
          assume "T  deadlocked s"
          with Red show ?thesis by(auto dest: red_no_deadlock)
        next
          assume "final_thread s T"
          with Red show ?thesis
            by(auto dest!: final_no_redT simp add: final_thread_def)
        qed
        with s' tst Red ‹has_lock (locks s $ l) T have "has_lock (locks s' $ l) T"
          by -(cases s, auto dest: redT_has_lock_inv[THEN iffD2])
        moreover
        from s' T  t have wset: "wset s T = None  wset s' T = None"
          by(auto intro: redT_updWs_None_implies_None)
        { fix x
          assume "thr s T = (x, no_wait_locks)"
          with T  t Red s' aok tst have "thr s' T = (x, no_wait_locks)"
            by(auto intro: redT_updTs_Some) }
        moreover
        hence "final_thread s T  final_thread s' T"
          by(auto simp add: final_thread_def intro: wset)
        moreover from ¬ waiting (wset s t'') s' t''t
        have "¬ waiting (wset s' t'')"
          by(auto simp add: redT_updWs_None_implies_None redT_updWs_PostWS_imp_PostWS not_waiting_iff)
        ultimately have ?Acquire
          using 0 < ln $ l t''  T T  deadlocked s  final_thread s T by(auto)
        thus ?thesis by simp
      qed
    qed
  next
    case (redT_acquire x n ln)
    hence [simp]: "ta = (K$ [], [], [], [], [], convert_RA ln)"
      and s': "s' = (acquire_all (locks s) t ln, (thr s(t  (x, no_wait_locks)), shr s), wset s, interrupts s)"
      and tst: "thr s t = (x, ln)" 
      and wst: "¬ waiting (wset s t)" by auto
    from t'dead show ?thesis
    proof(coinduct)
      case (deadlocked t'')
      note t''dead = this
      with Red have t''t: "t''  t"
        by(auto dest: red_no_deadlock)
      from t''dead show ?case
      proof(cases rule: deadlocked_elims)
        case (lock X)
        note clnml = LT. t''  X, shr s LT   lt  LT. must_wait s t'' lt (deadlocked s  final_threads s)
        note tst'' = ‹thr s t'' = (X, no_wait_locks)
        with s' t''t have ts't'': "thr s' t'' = (X, no_wait_locks)" by simp
        moreover 
        { fix LT
          assume "t''  X, shr s' LT "
          hence "t''  X, shr s LT " using s' by simp
          then obtain lt where lt: "lt  LT" and hlnft: "must_wait s t'' lt (deadlocked s  final_threads s)"
            by(blast dest: clnml)
          from hlnft have "must_wait s' t'' lt (deadlocked s  deadlocked s'  final_threads s')"
          proof(cases rule: must_wait_elims)
            case (lock l' T)
            from ‹has_lock (locks s $ l') T s'
            have "has_lock (locks s' $ l') T"
              by(auto intro: has_lock_has_lock_acquire_locks)
            moreover note T  t''
            moreover from T  deadlocked s  final_threads s
            have "T  deadlocked s  deadlocked s'  final_threads s'" using subset by blast
            ultimately show ?thesis unfolding lt = Inl l' ..
          next
            case (join T)
            from ‹not_final_thread s T have "thr s T  None"
              by(auto simp add: not_final_thread_iff)
            moreover
            from T  deadlocked s  final_threads s
            have "T  t"
            proof
              assume "T  deadlocked s"
              with Red show ?thesis by(auto dest: red_no_deadlock)
            next
              assume "T  final_threads s"
              with 0 < ln $ n tst show ?thesis
                by(auto simp add: final_thread_def)
            qed
            ultimately have "not_final_thread s' T" using ‹not_final_thread s T s'
              by(auto simp add: not_final_thread_iff)
            moreover from T  deadlocked s  final_threads s
            have "T  deadlocked s  deadlocked s'  final_threads s'" using subset by blast
            ultimately show ?thesis unfolding lt = Inr (Inl T) ..
          next
            case (interrupt T)
            from tst wst 0 < ln $ n have "not_final_thread s t"
              by(auto simp add: waiting_def not_final_thread_iff)
            with ‹all_final_except s (deadlocked s  final_threads s)
            have "t  deadlocked s  final_threads s" by(rule all_final_exceptD)
            moreover have "t  deadlocked s" using Red by(blast dest: red_no_deadlock)
            moreover have "¬ final_thread s t" using tst 0 < ln $ n by(auto simp add: final_thread_def)
            ultimately have False by blast
            thus ?thesis ..
          qed
          with lt have "ltLT. must_wait s' t'' lt (deadlocked s  deadlocked s'  final_threads s')" by blast }
        moreover from ‹wset s t'' = None› s' have "wset s' t'' = None" by simp
        ultimately show ?thesis using ‹thr s t'' = (X, no_wait_locks) t''  X, shr s  s' by fastforce
      next
        case (wait X LN)
        have "all_final_except s' (deadlocked s)"
        proof(rule all_final_exceptI)
          fix T
          assume "not_final_thread s' T"
          hence "not_final_thread s T" using wst tst s'
            by(auto simp add: not_final_thread_iff split: if_split_asm)
          with ‹all_final_except s (deadlocked s) ‹thr s t = (x, ln)
          show "T  deadlocked s" by-(erule all_final_exceptD)
        qed
        hence "all_final_except s' (deadlocked s  deadlocked s')"
          by(rule all_final_except_mono') blast
        with t''t ‹thr s t'' = (X, LN) ‹waiting (wset s t'') s' 
        have ?Wait by simp
        thus ?thesis by simp
      next
        case (acquire X LN l T)
        from ‹thr s t'' = (X, LN) t''t s'
        have "thr s' t'' = (X, LN)" by(simp)
        moreover from T  deadlocked s  final_thread s T s' tst 
        have "T  deadlocked s  final_thread s' T"
          by(clarsimp simp add: final_thread_def)
        moreover from ‹has_lock (locks s $ l) T s'
        have "has_lock (locks s' $ l) T"
          by(auto intro: has_lock_has_lock_acquire_locks)
        moreover have "¬ waiting (wset s' t'')" using ¬ waiting (wset s t'') s' by simp
        ultimately show ?thesis using 0 < LN $ l t''  T by blast
      qed
    qed
  qed
qed

corollary RedT_deadlocked_subset:
  assumes wfs: "s  wf_state"
  and Red: "s -▹ttas→* s'"
  shows "deadlocked s  deadlocked s'"
using Red 
apply(induct rule: RedT_induct')
apply(unfold RedT_def)
apply(blast dest: invariant3p_rtrancl3p[OF invariant3p_wf_state _ wfs] redT_deadlocked_subset)+
done

end

end

Theory FWProgress

(*  Title:      JinjaThreads/Framework/FWProgress.thy
    Author:     Andreas Lochbihler
*)

section ‹Progress theorem for the multithreaded semantics›

theory FWProgress
imports
  FWDeadlock
begin

locale progress = multithreaded final r convert_RA 
  for final :: "'x  bool"
  and r :: "('l,'t,'x,'m,'w,'o) semantics" ("_  _ -_ _" [50,0,0,50] 80)
  and convert_RA :: "'l released_locks  'o list"
  +
  fixes wf_state :: "('l,'t,'x,'m,'w) state set"
  assumes wf_stateD: "s  wf_state  lock_thread_ok (locks s) (thr s)  wset_final_ok (wset s) (thr s)"
  and wf_red:
  " s  wf_state; thr s t = (x, no_wait_locks);
     t  (x, shr s) -ta (x', m'); ¬ waiting (wset s t) 
   ta' x' m'. t  (x, shr s) -ta' (x', m')  (actions_ok s t ta'  actions_ok' s t ta'  actions_subset ta' ta)"

  and red_wait_set_not_final:
  " s  wf_state; thr s t = (x, no_wait_locks); 
    t  (x, shr s) -ta (x', m'); ¬ waiting (wset s t); Suspend w  set taw  
   ¬ final x'"

  and wf_progress:
  " s  wf_state; thr s t = (x, no_wait_locks); ¬ final x 
   ta x' m'. t  x, shr s -ta x', m'"

  and ta_Wakeup_no_join_no_lock_no_interrupt: 
  " s  wf_state; thr s t = (x, no_wait_locks); t  xm -ta xm'; Notified  set taw  WokenUp  set taw  
   collect_waits ta = {}"

  and ta_satisfiable:
  " s  wf_state; thr s t = (x, no_wait_locks); t  x, shr s -ta x', m' 
   s'. actions_ok s' t ta"
begin

lemma wf_redE:
  assumes "s  wf_state" "thr s t = (x, no_wait_locks)"
  and "t  x, shr s -ta x'', m''" "¬ waiting (wset s t)"
  obtains ta' x' m'
  where "t  x, shr s -ta' x', m'" "actions_ok' s t ta'" "actions_subset ta' ta"
  | ta' x' m' where "t  x, shr s -ta' x', m'" "actions_ok s t ta'"
using wf_red[OF assms] by blast

lemma wf_progressE:
  assumes "s  wf_state"
  and "thr s t = (x, no_wait_locks)" "¬ final x"
  obtains ta x' m' where "t  x, shr s -ta x', m'"
using assms
by(blast dest: wf_progress)

lemma wf_progress_satisfiable:
  " s  wf_state; thr s t = (x, no_wait_locks); ¬ final x  
   ta x' m' s'. t  x, shr s -ta x', m'  actions_ok s' t ta"
apply(frule (2) wf_progress)
apply(blast dest: ta_satisfiable)
done

theorem redT_progress:
  assumes wfs: "s  wf_state" 
  and ndead: "¬ deadlock s"
  shows "t' ta' s'. s -t'ta' s'"
proof -
  from wfs have lok: "lock_thread_ok (locks s) (thr s)"
    and wfin: "wset_final_ok (wset s) (thr s)"
    by(auto dest: wf_stateD)
  from ndead
  have "t x ln l. thr s t = (x, ln)  
          (wset s t = None  ln = no_wait_locks  ¬ final x  (LT. t  x, shr s LT   (lt  LT. ¬ must_wait s t lt (dom (thr s)))) 
           ¬ waiting (wset s t)  ln $ l > 0  (l. ln $ l > 0  may_lock (locks s $ l) t) 
          (w. ln = no_wait_locks  wset s t = PostWS w))"
    by(rule contrapos_np)(blast intro!: all_waiting_implies_deadlock[OF lok] intro: must_syncI[OF wf_progress_satisfiable[OF wfs]])
  then obtain t x ln l
    where tst: "thr s t = (x, ln)"
    and a: "wset s t = None  ln = no_wait_locks  ¬ final x  
              (LT. t  x, shr s LT   (lt  LT. ¬ must_wait s t lt (dom (thr s)))) 
            ¬ waiting (wset s t)  ln $ l > 0  (l. ln $ l > 0  may_lock (locks s $ l) t) 
            (w. ln = no_wait_locks  wset s t = PostWS w)"
    by blast
  from a have cases[case_names normal acquire wakeup]:
    "thesis. 
         LT.  wset s t = None; ln = no_wait_locks; ¬ final x; t  x, shr s LT ; 
                 lt. lt  LT  ¬ must_wait s t lt (dom (thr s))   thesis;
           ¬ waiting (wset s t); ln $ l > 0; l. ln $ l > 0  may_lock (locks s $ l) t   thesis;
          w.  ln = no_wait_locks; wset s t = PostWS w   thesis   thesis"
    by auto
  show ?thesis
  proof(cases rule: cases)
    case (normal LT)
    note [simp] = ln = no_wait_locks› 
      and nfine' = ¬ final x
      and cl' = t  x, shr s LT  
      and mw = lt. ltLT  ¬ must_wait s t lt (dom (thr s))
    from tst nfine' obtain x'' m'' ta'
      where red: "t  x, shr s -ta' x'', m''"
      by(auto intro: wf_progressE[OF wfs])
    from cl'
    have "ta''' x''' m'''. t  x, shr s -ta''' x''', m'''  
            LT = collect_waits ta'''"
      by (fastforce elim!: can_syncE)
    then obtain ta''' x''' m'''
      where red'': "t  x, shr s -ta''' x''', m'''"
      and L: "LT = collect_waits ta'''"
      by blast
    from ‹wset s t = None› have "¬ waiting (wset s t)" by(simp add: not_waiting_iff)
    with tst obtain ta'' x'' m''
      where red': "t  x, shr s -ta'' x'', m''"
      and aok': "actions_ok s t ta''  actions_ok' s t ta''  actions_subset ta'' ta'''"
      by -(rule wf_redE[OF wfs _ red''], auto)
    from aok' have "actions_ok s t ta''"
    proof
      assume "actions_ok' s t ta''  actions_subset ta'' ta'''"
      hence aok': "actions_ok' s t ta''" and aos: "actions_subset ta'' ta'''" by simp_all

      { fix l
        assume "Inl l  LT"
        { fix t'
          assume "t  t'"
          have "¬ has_lock (locks s $ l) t'"
          proof
            assume "has_lock (locks s $ l) t'"
            moreover with lok have "thr s t'  None" by(auto dest: lock_thread_okD)
            ultimately have "must_wait s t (Inl l) (dom (thr s))" using t  t' by(auto)
            moreover from ‹Inl l  LT have "¬ must_wait s t (Inl l) (dom (thr s))" by(rule mw)
            ultimately show False by contradiction
          qed }
        hence "may_lock (locks s $ l) t"
          by-(rule classical, auto simp add: not_may_lock_conv) }
      note mayl = this
      { fix t'
        assume t'LT: "Inr (Inl t')  LT"
        hence "¬ not_final_thread s t'  t'  t"
        proof(cases "t' = t")
          case False with t'LT mw L show ?thesis by(fastforce)
        next
          case True with tst mw[OF t'LT] nfine' L have False
            by(auto intro!: must_wait.intros simp add: not_final_thread_iff)
          thus ?thesis ..
        qed }
      note mayj = this
      { fix t'
        assume t': "Inr (Inr t')  LT"
        from t' have "¬ must_wait s t (Inr (Inr t')) (dom (thr s))" by(rule mw)
        hence "t'  interrupts s"
          by(rule contrapos_np)(fastforce intro: all_final_exceptI simp add: not_final_thread_iff) }
      note interrupt = this
      from aos L mayl
      have "l. l  collect_locks' ta''l  may_lock (locks s $ l) t" by auto
      with aok' have "lock_ok_las (locks s) t ta''l" by(auto intro: lock_ok_las'_into_lock_on_las)
      moreover
      from mayj aos L
      have "cond_action_oks s t ta''c"
        by(fastforce intro: may_join_cond_action_oks)
      moreover
      from ta_satisfiable[OF wfs tst[simplified] red']
      obtain is' where "interrupt_actions_ok is' ta''i" by auto
      with interrupt aos aok' L have "interrupt_actions_ok (interrupts s) ta''i"
        by(auto 5 2 intro: interrupt_actions_ok'_collect_interrupts_imp_interrupt_actions_ok)
      ultimately show "actions_ok s t ta''" using aok' by auto
    qed
    moreover obtain ws'' where "redT_updWs t (wset s) ta''w ws''"
      using redT_updWs_total[of t "wset s" "ta''w"] ..
    then obtain s' where "redT_upd s t ta'' x'' m'' s'" by fastforce
    ultimately have "s -tta'' s'"
      using red' tst ‹wset s t = None› by(auto intro: redT_normal)
    thus ?thesis by blast
  next
    case acquire
    hence "may_acquire_all (locks s) t ln" by(auto)
    with tst ¬ waiting (wset s t) 0 < ln $ l
    show ?thesis by(fastforce intro: redT_acquire)
  next
    case (wakeup w)
    from ‹wset s t = PostWS w
    have "¬ waiting (wset s t)" by(simp add: not_waiting_iff)
    from tst wakeup have tst: "thr s t = (x, no_wait_locks)" by simp
    from wakeup tst wfin have "¬ final x" by(auto dest: wset_final_okD)
    from wf_progress[OF wfs tst this]
    obtain ta x' m' where red: "t  x, shr s -ta x', m'" by auto
    from wf_red[OF wfs tst red ¬ waiting (wset s t)]
    obtain ta' x'' m'' 
      where red': "t  x, shr s -ta' x'', m''"
      and aok': "actions_ok s t ta'  actions_ok' s t ta'  actions_subset ta' ta" by blast
    from aok' have "actions_ok s t ta'"
    proof
      assume "actions_ok' s t ta'  actions_subset ta' ta"
      hence aok': "actions_ok' s t ta'"
        and subset: "actions_subset ta' ta" by simp_all
      from wakeup aok' have "Notified  set ta'w  WokenUp  set ta'w"
        by(auto simp add: wset_actions_ok_def split: if_split_asm)
      from ta_Wakeup_no_join_no_lock_no_interrupt[OF wfs tst red' this]
      have no_join: "collect_cond_actions ta'c = {}" 
        and no_lock: "collect_locks ta'l = {}" 
        and no_interrupt: "collect_interrupts ta'i = {}" by auto
      from no_lock have no_lock': "collect_locks' ta'l = {}"
        using collect_locks'_subset_collect_locks[of "ta'l"] by auto
      from aok' have "lock_ok_las' (locks s) t ta'l" by auto
      hence "lock_ok_las (locks s) t ta'l"
        by(rule lock_ok_las'_into_lock_on_las)(simp add: no_lock')
      moreover from subset aok' no_join have "cond_action_oks s t ta'c"
        by(auto intro: may_join_cond_action_oks)
      moreover from ta_satisfiable[OF wfs tst[simplified] red']
      obtain is' where "interrupt_actions_ok is' ta'i" by auto
      with aok' no_interrupt have "interrupt_actions_ok (interrupts s) ta'i"
        by(auto intro: interrupt_actions_ok'_collect_interrupts_imp_interrupt_actions_ok)
      ultimately show "actions_ok s t ta'" using aok' by auto
    qed
    moreover obtain ws'' where "redT_updWs t (wset s) ta'w ws''"
      using redT_updWs_total[of t "wset s" "ta'w"] ..
    then obtain s' where "redT_upd s t ta' x'' m'' s'" by fastforce
    ultimately have "s -tta' s'" using tst red' wakeup
      by(auto intro: redT_normal)
    thus ?thesis by blast
  qed
qed

end

end

Theory FWLifting

(*  Title:      JinjaThreads/Framework/FWLifting.thy
    Author:     Andreas Lochbihler
*)

section ‹Lifting of thread-local properties to the multithreaded case›

theory FWLifting
imports
  FWWellform
begin

text‹Lifting for properties that only involve thread-local state information and the shared memory.›

definition
  ts_ok :: "('t  'x  'm  bool)  ('l, 't,'x) thread_info  'm  bool"
where
  "ln. ts_ok P ts m  t. case (ts t) of None  True | (x, ln)  P t x m"

lemma ts_okI:
  " t x ln. ts t = (x, ln)  P t x m   ts_ok P ts m"
by(auto simp add: ts_ok_def)

lemma ts_okE:
  " ts_ok P ts m;  t x ln. ts t = (x, ln)  P t x m   Q   Q"
by(auto simp add: ts_ok_def)

lemma ts_okD:
  "ln.  ts_ok P ts m; ts t = (x, ln)   P t x m"
by(auto simp add: ts_ok_def)

lemma ts_ok_True [simp]:
  "ts_ok (λt m x. True) ts m"
by(auto intro: ts_okI)

lemma ts_ok_conj:
  "ts_ok (λt x m. P t x m  Q t x m) = (λts m. ts_ok P ts m  ts_ok Q ts m)"
by(auto intro: ts_okI intro!: ext dest: ts_okD)

lemma ts_ok_mono:
  " ts_ok P ts m; t x. P t x m  Q t x m   ts_ok Q ts m"
by(auto intro!: ts_okI dest: ts_okD)

text‹Lifting for properites, that also require additional data that does not change during execution›

definition
  ts_inv :: "('i  't  'x  'm  bool)  ('t  'i)  ('l,'t,'x) thread_info  'm  bool"
where
  "ln. ts_inv P I ts m  t. case (ts t) of None  True | (x, ln)  i. I t = i  P i t x m" 

lemma ts_invI:
  " t x ln. ts t = (x, ln)  i. I t = i  P i t x m   ts_inv P I ts m"
by(simp add: ts_inv_def)

lemma ts_invE:
  " ts_inv P I ts m; t x ln. ts t = (x, ln)  (i. I t = i  P i t x m)  R   R"
by(auto simp add: ts_inv_def)

lemma ts_invD:
  "ln.  ts_inv P I ts m; ts t = (x, ln)   i. I t = i  P i t x m"
by(auto simp add: ts_inv_def)

text ‹Wellformedness properties for lifting›

definition
  ts_inv_ok :: "('l,'t,'x) thread_info  ('t  'i)  bool"
where
  "ts_inv_ok ts I  t. ts t = None  I t = None"

lemma ts_inv_okI:
  "(t. ts t = None  I t = None)  ts_inv_ok ts I"
by(clarsimp simp add: ts_inv_ok_def)

lemma ts_inv_okI2:
  "(t. (v. ts t = v)  (v. I t = v))  ts_inv_ok ts I"
by(force simp add: ts_inv_ok_def)

lemma ts_inv_okE:
  " ts_inv_ok ts I; t. ts t = None  I t = None  P   P"
by(force simp add: ts_inv_ok_def)

lemma ts_inv_okE2:
  " ts_inv_ok ts I; t. (v. ts t = v)  (v. I t = v)  P   P"
by(force simp add: ts_inv_ok_def)

lemma ts_inv_okD:
  "ts_inv_ok ts I  (ts t = None)  (I t = None)"
by(erule ts_inv_okE, blast)

lemma ts_inv_okD2:
  "ts_inv_ok ts I  (v. ts t = v)  (v. I t = v)"
by(erule ts_inv_okE2, blast)

lemma ts_inv_ok_conv_dom_eq:
  "ts_inv_ok ts I  (dom ts = dom I)"
proof -
  have "ts_inv_ok ts I  (t. ts t = None  I t = None)"
    unfolding ts_inv_ok_def by blast
  also have "  (t. t  - dom ts  t  - dom I)" by(force)
  also have "  dom ts = dom I" by auto
  finally show ?thesis .
qed

lemma ts_inv_ok_upd_ts:
  " ts t = x; ts_inv_ok ts I   ts_inv_ok (ts(t  x')) I"
by(auto dest!: ts_inv_okD intro!: ts_inv_okI split: if_splits)

lemma ts_inv_upd_map_option:
  assumes "ts_inv P I ts m"
  and "x ln. ts t = (x, ln)  P (the (I t)) t (fst (f (x, ln))) m"
  shows "ts_inv P I (ts(t := (map_option f (ts t)))) m"
using assms
by(fastforce intro!: ts_invI split: if_split_asm dest: ts_invD)

fun upd_inv :: "('t  'i)  ('i  't  'x  'm  bool)  ('t,'x,'m) new_thread_action  ('t  'i)"
where
  "upd_inv I P (NewThread t x m) = I(t  SOME i. P i t x m)"
| "upd_inv I P _ = I"

fun upd_invs :: "('t  'i)  ('i  't  'x  'm  bool)  ('t,'x,'m) new_thread_action list  ('t  'i)"
where
  "upd_invs I P [] = I"
| "upd_invs I P (ta#tas) = upd_invs (upd_inv I P ta) P tas"

lemma upd_invs_append [simp]:
  "upd_invs I P (xs @ ys) = upd_invs (upd_invs I P xs) P ys"
by(induct xs arbitrary: I)(auto)

lemma ts_inv_ok_upd_inv':
 "ts_inv_ok ts I  ts_inv_ok (redT_updT' ts ta) (upd_inv I P ta)"
by(cases ta)(auto intro!: ts_inv_okI elim: ts_inv_okD del: iffI)

lemma ts_inv_ok_upd_invs':
  "ts_inv_ok ts I  ts_inv_ok (redT_updTs' ts tas) (upd_invs I P tas)"
proof(induct tas arbitrary: ts I)
  case Nil thus ?case by simp
next
  case (Cons TA TAS TS I)
  note IH = ts I. ts_inv_ok ts I  ts_inv_ok (redT_updTs' ts TAS) (upd_invs I P TAS)
  note esok = ‹ts_inv_ok TS I
  from esok have "ts_inv_ok (redT_updT' TS TA) (upd_inv I P TA)"
    by -(rule ts_inv_ok_upd_inv')
  hence "ts_inv_ok (redT_updTs' (redT_updT' TS TA) TAS) (upd_invs (upd_inv I P TA) P TAS)"
    by (rule IH)
  thus ?case by simp
qed

lemma ts_inv_ok_upd_inv:
 "ts_inv_ok ts I  ts_inv_ok (redT_updT ts ta) (upd_inv I P ta)"
apply(cases ta)
apply(auto intro!: ts_inv_okI elim: ts_inv_okD del: iffI)
done

lemma ts_inv_ok_upd_invs:
  "ts_inv_ok ts I  ts_inv_ok (redT_updTs ts tas) (upd_invs I P tas)"
proof(induct tas arbitrary: ts I)
  case Nil thus ?case by simp
next
  case (Cons TA TAS TS I)
  note IH = ts I. ts_inv_ok ts I  ts_inv_ok (redT_updTs ts TAS) (upd_invs I P TAS)
  note esok = ‹ts_inv_ok TS I
  from esok have "ts_inv_ok (redT_updT TS TA) (upd_inv I P TA)"
    by -(rule ts_inv_ok_upd_inv)
  hence "ts_inv_ok (redT_updTs (redT_updT TS TA) TAS) (upd_invs (upd_inv I P TA) P TAS)"
    by (rule IH)
  thus ?case by simp
qed

lemma ts_inv_ok_inv_ext_upd_inv:
  " ts_inv_ok ts I; thread_ok ts ta   I m upd_inv I P ta"
by(cases ta)(auto intro!: map_le_same_upd dest: ts_inv_okD)

lemma ts_inv_ok_inv_ext_upd_invs:
  " ts_inv_ok ts I; thread_oks ts tas
   I m upd_invs I P tas"
proof(induct tas arbitrary: ts I)
  case Nil thus ?case by simp
next
  case (Cons TA TAS TS I)
  note IH = ts I.  ts_inv_ok ts I; thread_oks ts TAS  I m upd_invs I P TAS
  note esinv = ‹ts_inv_ok TS I
  note cct = ‹thread_oks TS (TA # TAS)
  from esinv cct have "I m upd_inv I P TA"
    by(auto intro: ts_inv_ok_inv_ext_upd_inv)
  also from esinv cct have "ts_inv_ok (redT_updT' TS TA) (upd_inv I P TA)"
    by(auto intro: ts_inv_ok_upd_inv')
  with cct have "upd_inv I P TA m upd_invs (upd_inv I P TA) P TAS"
    by(auto intro: IH)
  finally show ?case by simp
qed

lemma upd_invs_Some:
  " thread_oks ts tas; I t = i; ts t = x   upd_invs I Q tas t = i"
proof(induct tas arbitrary: ts I)
  case Nil thus ?case by simp
next
  case (Cons TA TAS TS I)
  note IH = ts I. thread_oks ts TAS; I t = i; ts t = x  upd_invs I Q TAS t = i
  note cct = ‹thread_oks TS (TA # TAS)
  note it = I t = i
  note est = TS t = x
  from cct have cctta: "thread_ok TS TA"
    and ccttas: "thread_oks (redT_updT' TS TA) TAS" by auto
  from cctta it est have "upd_inv I Q TA t = i"
    by(cases TA, auto)
  moreover
  have "redT_updT' TS TA t = x" using cctta est
    by - (rule redT_updT'_Some) 
  ultimately have "upd_invs (upd_inv I Q TA) Q TAS t = i" using ccttas
    by -(erule IH)
  thus ?case by simp
qed

lemma upd_inv_Some_eq:
  " thread_ok ts ta; ts t = x   upd_inv I Q ta t = I t"
by(cases ta, auto)

lemma upd_invs_Some_eq: " thread_oks ts tas; ts t = x   upd_invs I Q tas t = I t"
proof(induct tas arbitrary: ts I)
  case Nil thus ?case by simp
next
  case (Cons TA TAS TS I)
  note IH = ts I. thread_oks ts TAS; ts t = x  upd_invs I Q TAS t = I t
  note cct = ‹thread_oks TS (TA # TAS)
  note est = TS t = x
  from cct est have "upd_invs (upd_inv I Q TA) Q TAS t = upd_inv I Q TA t"
    apply(clarsimp)
    apply(erule IH)
    by(rule redT_updT'_Some)
  also from cct est have " = I t" 
    by(auto elim: upd_inv_Some_eq)
  finally show ?case by simp
qed

lemma SOME_new_thread_upd_invs:
  assumes Qsome: "Q (SOME i. Q i t x m) t x m"
  and nt: "NewThread t x m  set tas"
  and cct: "thread_oks ts tas"
  shows "i. upd_invs I Q tas t = i  Q i t x m"
proof(rule exI[where x="SOME i. Q i t x m"])
  from nt cct have "upd_invs I Q tas t = SOME i. Q i t x m"
  proof(induct tas arbitrary: ts I)
    case Nil thus ?case by simp
  next
    case (Cons TA TAS TS I)
    note IH = ts I.  NewThread t x m  set TAS; thread_oks ts TAS   upd_invs I Q TAS t = SOME i. Q i t x m
    note nt = ‹NewThread t x m  set (TA # TAS)
    note cct = ‹thread_oks TS (TA # TAS)
    { assume nt': "NewThread t x m  set TAS"
      from cct have ?case
        apply(clarsimp)
        by(rule IH[OF nt']) }
    moreover
    { assume ta: "TA = NewThread t x m"
      with cct have rup: "redT_updT' TS TA t = (undefined, no_wait_locks)"
        by(simp)
      from cct have cctta: "thread_oks (redT_updT' TS TA) TAS" by simp
      from ta have "upd_inv I Q TA t = SOME i. Q i t x m"
        by(simp)
      hence ?case 
        by(clarsimp simp add: upd_invs_Some_eq[OF cctta, OF rup]) }
    ultimately show ?case using nt by auto
  qed
  with Qsome show "upd_invs I Q tas t = SOME i. Q i t x m  Q (SOME i. Q i t x m) t x m"
    by(simp)
qed

lemma ts_ok_into_ts_inv_const:
  assumes "ts_ok P ts m"
  obtains I where "ts_inv (λ_. P) I ts m"
proof -
  from assms have "ts_inv (λ_. P) (λt. if t  dom ts then Some undefined else None) ts m"
    by(auto intro!: ts_invI dest: ts_okD)
  thus thesis by(rule that)
qed

lemma ts_inv_const_into_ts_ok:
  "ts_inv (λ_. P) I ts m  ts_ok P ts m"
by(auto intro!: ts_okI dest: ts_invD)

lemma ts_inv_into_ts_ok_Ex:
  "ts_inv Q I ts m  ts_ok (λt x m. i. Q i t x m) ts m"
by(rule ts_okI)(blast dest: ts_invD)

lemma ts_ok_Ex_into_ts_inv:
  "ts_ok (λt x m. i. Q i t x m) ts m  I. ts_inv Q I ts m"
by(rule exI[where x="λt. SOME i. Q i t (fst (the (ts t))) m"])(auto 4 4 dest: ts_okD intro: someI intro: ts_invI)

lemma Ex_ts_inv_conv_ts_ok:
  "(I. ts_inv Q I ts m)  (ts_ok (λt x m. i. Q i t x m) ts m)"
by(auto dest: ts_inv_into_ts_ok_Ex ts_ok_Ex_into_ts_inv)

end

Theory LTS

(*  Title:      JinjaThreads/Framework/LTS.thy
    Author:     Andreas Lochbihler
*)

section ‹Labelled transition systems›

theory LTS
imports
  "../Basic/Auxiliary"
  Coinductive.TLList
begin

no_notation floor ("_")

lemma rel_option_mono:
  " rel_option R x y; x y. R x y  R' x y   rel_option R' x y"
by(cases x)(case_tac [!] y, auto)

lemma nth_concat_conv:
  "n < length (concat xss) 
    m n'. concat xss ! n = (xss ! m) ! n'  n' < length (xss ! m)  
             m < length xss  n = (i<m. length (xss ! i)) + n'"
using lnth_lconcat_conv[of n "llist_of (map llist_of xss)"]
  sum_hom[where f = enat and h = "λi. length (xss ! i)"]
by(clarsimp simp add: lconcat_llist_of zero_enat_def[symmetric]) blast


definition flip :: "('a  'b  'c)  'b  'a  'c"
where "flip f = (λb a. f a b)"

text ‹Create a dynamic list flip_simps› of theorems for flip›
ML structure FlipSimpRules = Named_Thms
(
  val name = @{binding flip_simps}
  val description = "Simplification rules for flip in bisimulations"
)
setup FlipSimpRules.setup

lemma flip_conv [flip_simps]: "flip f b a = f a b"
by(simp add: flip_def)

lemma flip_flip [flip_simps, simp]: "flip (flip f) = f"
by(simp add: flip_def)

lemma list_all2_flip [flip_simps]: "list_all2 (flip P) xs ys = list_all2 P ys xs"
unfolding flip_def list_all2_conv_all_nth by auto

lemma llist_all2_flip [flip_simps]: "llist_all2 (flip P) xs ys = llist_all2 P ys xs"
unfolding flip_def llist_all2_conv_all_lnth by auto

lemma rtranclp_flipD:
  assumes "(flip r)^** x y"
  shows "r^** y x" 
using assms
by(induct rule: rtranclp_induct)(auto intro: rtranclp.rtrancl_into_rtrancl simp add: flip_conv)

lemma rtranclp_flip [flip_simps]:
  "(flip r)^** = flip r^**"
by(auto intro!: ext simp add: flip_conv intro: rtranclp_flipD)

lemma rel_prod_flip [flip_simps]:
  "rel_prod (flip R) (flip S) = flip (rel_prod R S)"
by(auto intro!: ext simp add: flip_def)

lemma rel_option_flip [flip_simps]:
  "rel_option (flip R) = flip (rel_option R)"
by(simp add: fun_eq_iff rel_option_iff flip_def)

lemma tllist_all2_flip [flip_simps]:
  "tllist_all2 (flip P) (flip Q) xs ys  tllist_all2 P Q ys xs"
proof
  assume "tllist_all2 (flip P) (flip Q) xs ys"
  thus "tllist_all2 P Q ys xs"
    by(coinduct rule: tllist_all2_coinduct)(auto dest: tllist_all2_is_TNilD tllist_all2_tfinite2_terminalD tllist_all2_thdD intro: tllist_all2_ttlI simp add: flip_def)
next
  assume "tllist_all2 P Q ys xs"
  thus "tllist_all2 (flip P) (flip Q) xs ys"
    by(coinduct rule: tllist_all2_coinduct)(auto dest: tllist_all2_is_TNilD tllist_all2_tfinite2_terminalD tllist_all2_thdD intro: tllist_all2_ttlI simp add: flip_def)
qed

subsection ‹Labelled transition systems›

type_synonym ('a, 'b) trsys = "'a  'b  'a  bool"

locale trsys = 
  fixes trsys :: "('s, 'tl) trsys" ("_/ -_/ _" [50, 0, 50] 60)
begin

abbreviation Trsys :: "('s, 'tl list) trsys" ("_/ -_→*/ _" [50,0,50] 60)
where "tl. s -tl→* s'  rtrancl3p trsys s tl s'"

coinductive inf_step :: "'s  'tl llist  bool" ("_ -_→* " [50, 0] 80)
where inf_stepI: " trsys a b a'; a' -bs→*    a -LCons b bs→* "

coinductive inf_step_table :: "'s  ('s × 'tl × 's) llist  bool" ("_ -_→*t " [50, 0] 80)
where 
  inf_step_tableI:
  "tl.  trsys s tl s'; s' -stls→*t   
   s -LCons (s, tl, s') stls→*t "

definition inf_step2inf_step_table :: "'s  'tl llist  ('s × 'tl × 's) llist"
where
  "inf_step2inf_step_table s tls =
   unfold_llist
     (λ(s, tls). lnull tls)
     (λ(s, tls). (s, lhd tls, SOME s'. trsys s (lhd tls) s'  s' -ltl tls→* )) 
     (λ(s, tls). (SOME s'. trsys s (lhd tls) s'  s' -ltl tls→* , ltl tls))
     (s, tls)"

coinductive Rtrancl3p :: "'s  ('tl, 's) tllist  bool"
where 
  Rtrancl3p_stop: "(tl s'. ¬ s -tl s')   Rtrancl3p s (TNil s)"
| Rtrancl3p_into_Rtrancl3p: "tl.  s -tl s'; Rtrancl3p s' tlss   Rtrancl3p s (TCons tl tlss)"
  
inductive_simps Rtrancl3p_simps:
  "Rtrancl3p s (TNil s')"
  "Rtrancl3p s (TCons tl' tlss)"

inductive_cases Rtrancl3p_cases:
  "Rtrancl3p s (TNil s')"
  "Rtrancl3p s (TCons tl' tlss)"

coinductive Runs :: "'s  'tl llist  bool"
where
  Stuck: "(tl s'. ¬ s -tl s')  Runs s LNil"
| Step: "tl.  s -tl s'; Runs s' tls   Runs s (LCons tl tls)"

coinductive Runs_table :: "'s  ('s × 'tl × 's) llist  bool"
where
  Stuck: "(tl s'. ¬ s -tl s')  Runs_table s LNil"
| Step: "tl.  s -tl s'; Runs_table s' stlss   Runs_table s (LCons (s, tl, s') stlss)"

inductive_simps Runs_table_simps:
  "Runs_table s LNil"
  "Runs_table s (LCons stls stlss)"

lemma inf_step_not_finite_llist:
  assumes r: "s -bs→* "
  shows "¬ lfinite bs"
proof
  assume "lfinite bs" thus False using r
    by(induct arbitrary: s rule: lfinite.induct)(auto elim: inf_step.cases)
qed

lemma inf_step2inf_step_table_LNil [simp]: "inf_step2inf_step_table s LNil = LNil"
by(simp add: inf_step2inf_step_table_def)

lemma inf_step2inf_step_table_LCons [simp]:
  fixes tl shows
  "inf_step2inf_step_table s (LCons tl tls) =
   LCons (s, tl, SOME s'. trsys s tl s'  s' -tls→* ) 
         (inf_step2inf_step_table (SOME s'. trsys s tl s'  s' -tls→* ) tls)"
by(simp add: inf_step2inf_step_table_def)

lemma lnull_inf_step2inf_step_table [simp]: 
  "lnull (inf_step2inf_step_table s tls)  lnull tls"
by(simp add: inf_step2inf_step_table_def)

lemma inf_step2inf_step_table_eq_LNil: 
  "inf_step2inf_step_table s tls = LNil  tls = LNil"
using lnull_inf_step2inf_step_table unfolding lnull_def .

lemma lhd_inf_step2inf_step_table [simp]:
  "¬ lnull tls
   lhd (inf_step2inf_step_table s tls) =
      (s, lhd tls, SOME s'. trsys s (lhd tls) s'  s' -ltl tls→* )"
by(simp add: inf_step2inf_step_table_def)

lemma ltl_inf_step2inf_step_table [simp]:
  "ltl (inf_step2inf_step_table s tls) =
   inf_step2inf_step_table (SOME s'. trsys s (lhd tls) s'  s' -ltl tls→* ) (ltl tls)"
by(cases tls) simp_all

lemma lmap_inf_step2inf_step_table: "lmap (fst  snd) (inf_step2inf_step_table s tls) = tls"
by(coinduction arbitrary: s tls) auto

lemma inf_step_imp_inf_step_table:
  assumes "s -tls→* "
  shows "stls. s -stls→*t   tls = lmap (fst  snd) stls"
proof -
  from assms have "s -inf_step2inf_step_table s tls→*t "
  proof(coinduction arbitrary: s tls)
    case (inf_step_table s tls)
    thus ?case
    proof cases
      case (inf_stepI tl s' tls')
      let ?s' = "SOME s'. trsys s tl s'  s' -tls'→* "
      have "trsys s tl ?s'  ?s' -tls'→* " by(rule someI)(blast intro: inf_stepI)
      thus ?thesis using tls = LCons tl tls' by auto
    qed
  qed
  moreover have "tls = lmap (fst  snd) (inf_step2inf_step_table s tls)"
    by(simp only: lmap_inf_step2inf_step_table)
  ultimately show ?thesis by blast
qed

lemma inf_step_table_imp_inf_step:
  "s-stls→*t  s -lmap (fst  snd) stls→* "
proof(coinduction arbitrary: s stls rule: inf_step.coinduct)
  case (inf_step s tls)
  thus ?case by cases auto
qed

lemma Runs_table_into_Runs:
  "Runs_table s stlss  Runs s (lmap (λ(s, tl, s'). tl) stlss)"
proof(coinduction arbitrary: s stlss)
  case (Runs s tls)
  thus ?case by (cases)auto
qed

lemma Runs_into_Runs_table:
  assumes "Runs s tls"
  obtains stlss
  where "tls = lmap (λ(s, tl, s'). tl) stlss"
  and "Runs_table s stlss"
proof -
  define stlss where "stlss s tls = unfold_llist
    (λ(s, tls). lnull tls)
    (λ(s, tls). (s, lhd tls, SOME s'. s -lhd tls s'  Runs s' (ltl tls)))
    (λ(s, tls). (SOME s'. s -lhd tls s'  Runs s' (ltl tls), ltl tls))
    (s, tls)"
    for s tls
  have [simp]:
    "s. stlss s LNil = LNil"
    "s tl tls. stlss s (LCons tl tls) = LCons (s, tl, SOME s'. s -tl s'  Runs s' tls) (stlss (SOME s'. s -tl s'  Runs s' tls) tls)"
    "s tls. lnull (stlss s tls)  lnull tls"
    "s tls. ¬ lnull tls  lhd (stlss s tls) = (s, lhd tls, SOME s'. s -lhd tls s'  Runs s' (ltl tls))"
    "s tls. ¬ lnull tls  ltl (stlss s tls) = stlss (SOME s'. s -lhd tls s'  Runs s' (ltl tls)) (ltl tls)"
    by(simp_all add: stlss_def)
  
  from assms have "tls = lmap (λ(s, tl, s'). tl) (stlss s tls)"
  proof(coinduction arbitrary: s tls)
    case Eq_llist
    thus ?case by cases(auto 4 3 intro: someI2)
  qed
  moreover
  from assms have "Runs_table s (stlss s tls)"
  proof(coinduction arbitrary: s tls)
    case (Runs_table s stlss')
    thus ?case
    proof(cases)
      case (Step s' tls' tl)
      let ?P = "λs'. s -tl s'  Runs s' tls'"
      from s -tl s' ‹Runs s' tls' have "?P s'" ..
      hence "?P (Eps ?P)" by(rule someI)
      with Step have ?Step by auto
      thus ?thesis ..
    qed simp
  qed
  ultimately show ?thesis by(rule that)
qed

lemma Runs_lappendE:
  assumes "Runs σ (lappend tls tls')"
  and "lfinite tls"
  obtains σ' where "σ -list_of tls→* σ'"
  and "Runs σ' tls'"
proof(atomize_elim)
  from ‹lfinite tls ‹Runs σ (lappend tls tls')
  show "σ'. σ -list_of tls→* σ'  Runs σ' tls'"
  proof(induct arbitrary: σ)
    case lfinite_LNil thus ?case by(auto)
  next
    case (lfinite_LConsI tls tl)
    from ‹Runs σ (lappend (LCons tl tls) tls')
    show ?case unfolding lappend_code
    proof(cases)
      case (Step σ')
      from ‹Runs σ' (lappend tls tls')  σ''. σ' -list_of tls→* σ''  Runs σ'' tls' ‹Runs σ' (lappend tls tls')
      obtain σ'' where "σ' -list_of tls→* σ''" "Runs σ'' tls'" by blast
      from σ -tl σ' σ' -list_of tls→* σ''
      have "σ -tl # list_of tls→* σ''" by(rule rtrancl3p_step_converse)
      with ‹lfinite tls have "σ -list_of (LCons tl tls)→* σ''" by(simp)
      with ‹Runs σ'' tls' show ?thesis by blast
    qed
  qed
qed

lemma Trsys_into_Runs:
  assumes "s -tls→* s'"
  and "Runs s' tls'"
  shows "Runs s (lappend (llist_of tls) tls')"
using assms
by(induct rule: rtrancl3p_converse_induct)(auto intro: Runs.Step)

lemma rtrancl3p_into_Rtrancl3p:
  " rtrancl3p trsys a bs a'; b a''. ¬ a' -b a''   Rtrancl3p a (tllist_of_llist a' (llist_of bs))"
  by(induct rule: rtrancl3p_converse_induct)(auto intro: Rtrancl3p.intros)
    
lemma Rtrancl3p_into_Runs:
  "Rtrancl3p s tlss  Runs s (llist_of_tllist tlss)"
by(coinduction arbitrary: s tlss rule: Runs.coinduct)(auto elim: Rtrancl3p.cases)

lemma Runs_into_Rtrancl3p:
  assumes "Runs s tls"
  obtains tlss where "tls = llist_of_tllist tlss" "Rtrancl3p s tlss"
proof
  let ?Q = "λs tls s'. s -lhd tls s'  Runs s' (ltl tls)"
  define tlss where "tlss = corec_tllist 
    (λ(s, tls). lnull tls) (λ(s, tls). s)
    (λ(s, tls). lhd tls)
    (λ_. False) undefined (λ(s, tls). (SOME s'. ?Q s tls s', ltl tls))"
  have [simp]:
    "tlss (s, LNil) = TNil s"
    "tlss (s, LCons tl tls) = TCons tl (tlss (SOME s'. ?Q s (LCons tl tls) s', tls))"
    for s tl tls by(auto simp add: tlss_def intro: tllist.expand)

  show "tls = llist_of_tllist (tlss (s, tls))" using assms
    by(coinduction arbitrary: s tls)(erule Runs.cases; fastforce intro: someI2)
      
  show "Rtrancl3p s (tlss (s, tls))" using assms
    by(coinduction arbitrary: s tls)(erule Runs.cases; simp; iprover intro: someI2[where Q="trsys _ _"] someI2[where Q="λs'. Runs s' _"])
qed

lemma fixes tl
  assumes "Rtrancl3p s tlss" "tfinite tlss"
  shows Rtrancl3p_into_Trsys: "Trsys s (list_of (llist_of_tllist tlss)) (terminal tlss)"
    and terminal_Rtrancl3p_final: "¬ terminal tlss -tl s'"
using assms(2,1) by(induction arbitrary: s rule: tfinite_induct)(auto simp add: Rtrancl3p_simps intro: rtrancl3p_step_converse)

end
  
subsection ‹Labelled transition systems with internal actions›

locale τtrsys = trsys +
  constrains trsys :: "('s, 'tl) trsys"
  fixes τmove :: "('s, 'tl) trsys"
begin

inductive silent_move :: "'s  's  bool" ("_ -τ→ _" [50, 50] 60)
where [intro]: "!!tl.  trsys s tl s'; τmove s tl s'   s -τ→ s'"

declare silent_move.cases [elim]

lemma silent_move_iff: "silent_move = (λs s'. (tl. trsys s tl s'  τmove s tl s'))"
by(auto simp add: fun_eq_iff)

abbreviation silent_moves :: "'s  's  bool" ("_ -τ→* _" [50, 50] 60)
where "silent_moves == silent_move^**"

abbreviation silent_movet :: "'s  's  bool" ("_ -τ→+ _" [50, 50] 60)
where "silent_movet == silent_move^++"

coinductive τdiverge :: "'s  bool" ("_ -τ→ " [50] 60)
where
  τdivergeI: " s -τ→ s'; s' -τ→    s -τ→ "

coinductive τinf_step :: "'s  'tl llist  bool" ("_ -τ-_→* " [50, 0] 60)
where
  τinf_step_Cons: "tl.  s -τ→* s'; s' -tl s''; ¬ τmove s' tl s''; s'' -τ-tls→*    s -τ-LCons tl tls→* "
| τinf_step_Nil: "s -τ→   s -τ-LNil→* "

coinductive τinf_step_table :: "'s  ('s × 's × 'tl × 's) llist  bool" ("_ -τ-_→*t " [50, 0] 80)
where
  τinf_step_table_Cons:
  "tl.  s -τ→* s'; s' -tl s''; ¬ τmove s' tl s''; s'' -τ-tls→*t    s -τ-LCons (s, s', tl, s'') tls→*t "

| τinf_step_table_Nil:
  "s -τ→   s -τ-LNil→*t "

definition τinf_step2τinf_step_table :: "'s  'tl llist  ('s × 's × 'tl × 's) llist"
where
  "τinf_step2τinf_step_table s tls =
   unfold_llist
     (λ(s, tls). lnull tls)
     (λ(s, tls). let (s', s'') = SOME (s', s''). s -τ→* s'  s' -lhd tls s''  ¬ τmove s' (lhd tls) s''  s'' -τ-ltl tls→* 
        in (s, s', lhd tls, s''))
     (λ(s, tls). let (s', s'') = SOME (s', s''). s -τ→* s'  s' -lhd tls s''  ¬ τmove s' (lhd tls) s''  s'' -τ-ltl tls→* 
        in (s'', ltl tls))
     (s, tls)"

definition silent_move_from :: "'s  's  's  bool"
where "silent_move_from s0 s1 s2  silent_moves s0 s1  silent_move s1 s2"

inductive τrtrancl3p :: "'s  'tl list  's  bool" ("_ -τ-_→* _" [50, 0, 50] 60)
where
  τrtrancl3p_refl: "τrtrancl3p s [] s"
| τrtrancl3p_step: "tl.  s -tl s'; ¬ τmove s tl s'; τrtrancl3p s' tls s''   τrtrancl3p s (tl # tls) s''"
| τrtrancl3p_τstep: "tl.  s -tl s'; τmove s tl s'; τrtrancl3p s' tls s''   τrtrancl3p s tls s''"

coinductive τRuns :: "'s  ('tl, 's option) tllist  bool" ("_  _" [50, 50] 51)
where
  Terminate: " s -τ→* s'; tl s''. ¬ s' -tl s''   s  TNil s'" 
| Diverge: "s -τ→   s  TNil None"
| Proceed: "tl.  s -τ→* s'; s' -tl s''; ¬ τmove s' tl s''; s''  tls   s  TCons tl tls"

inductive_simps τRuns_simps:
  "s  TNil (Some s')"
  "s  TNil None"
  "s  TCons tl' tls"

coinductive τRuns_table :: "'s  ('tl × 's, 's option) tllist  bool"
where 
  Terminate: " s -τ→* s'; tl s''. ¬ s' -tl s''   τRuns_table s (TNil s')"
| Diverge: "s -τ→   τRuns_table s (TNil None)"
| Proceed:
  "tl.  s -τ→* s'; s' -tl s''; ¬ τmove s' tl s''; τRuns_table s'' tls  
   τRuns_table s (TCons (tl, s'') tls)"

definition silent_move2 :: "'s  'tl  's  bool"
where "tl. silent_move2 s tl s'  s -tl s'  τmove s tl s'"

abbreviation silent_moves2 :: "'s  'tl list  's  bool"
where "silent_moves2  rtrancl3p silent_move2"

coinductive τRuns_table2 :: "'s  ('tl list × 's × 'tl × 's, ('tl list × 's) + 'tl llist) tllist  bool"
where 
  Terminate: " silent_moves2 s tls s'; tl s''. ¬ s' -tl s''   τRuns_table2 s (TNil (Inl (tls, s')))"
| Diverge: "trsys.inf_step silent_move2 s tls  τRuns_table2 s (TNil (Inr tls))"
| Proceed:
  "tl.  silent_moves2 s tls s'; s' -tl s''; ¬ τmove s' tl s''; τRuns_table2 s'' tlsstlss  
   τRuns_table2 s (TCons (tls, s', tl, s'') tlsstlss)"

inductive_simps τRuns_table2_simps:
  "τRuns_table2 s (TNil tlss)"
  "τRuns_table2 s (TCons tlsstls tlsstlss)"

lemma inf_step_table_all_τ_into_τdiverge:
  " s -stls→*t ; (s, tl, s')  lset stls. τmove s tl s'   s -τ→ "
proof(coinduction arbitrary: s stls)
  case (τdiverge s)
  thus ?case by cases (auto simp add: silent_move_iff, blast)
qed

lemma inf_step_table_lappend_llist_ofD:
  "s -lappend (llist_of stls) (LCons (x, tl', x') xs)→*t 
   (s -map (fst  snd) stls→* x)  (x -LCons (x, tl', x') xs→*t )"
proof(induct stls arbitrary: s)
  case Nil thus ?case by(auto elim: inf_step_table.cases intro: inf_step_table.intros rtrancl3p_refl)
next
  case (Cons st stls)
  note IH = s. s -lappend (llist_of stls) (LCons (x, tl', x') xs)→*t  
                 s -map (fst  snd) stls→* x  x -LCons (x, tl', x') xs→*t 
  from s -lappend (llist_of (st # stls)) (LCons (x, tl', x') xs)→*t 
  show ?case
  proof cases
    case (inf_step_tableI s' stls' tl)
    hence [simp]: "st = (s, tl, s')" "stls' = lappend (llist_of stls) (LCons (x, tl', x') xs)"
      and "s -tl s'" "s' -lappend (llist_of stls) (LCons (x, tl', x') xs)→*t " by simp_all
    from IH[OF s' -lappend (llist_of stls) (LCons (x, tl', x') xs)→*t ]
    have "s' -map (fst  snd) stls→* x" "x -LCons (x, tl', x') xs→*t " by auto
    with s -tl s' show ?thesis by(auto simp add: o_def intro: rtrancl3p_step_converse)
  qed
qed

lemma inf_step_table_lappend_llist_of_τ_into_τmoves:
  assumes "lfinite stls"
  shows " s -lappend stls (LCons (x, tl' x') xs)→*t ; (s, tl, s')lset stls. τmove s tl s'   s -τ→* x"
using assms
proof(induct arbitrary: s rule: lfinite.induct)
  case lfinite_LNil thus ?case by(auto elim: inf_step_table.cases)
next
  case (lfinite_LConsI stls st)
  note IH = s. s -lappend stls (LCons (x, tl' x') xs)→*t ; (s, tl, s')lset stls. τmove s tl s'   s -τ→* x
  obtain s1 tl1 s1' where [simp]: "st = (s1, tl1, s1')" by(cases st)
  from s -lappend (LCons st stls) (LCons (x, tl' x') xs)→*t 
  show ?case
  proof cases
    case (inf_step_tableI X' STLS TL)
    hence [simp]: "s1 = s" "TL = tl1" "X' = s1'" "STLS = lappend stls (LCons (x, tl' x') xs)"
      and "s -tl1 s1'" and "s1' -lappend stls (LCons (x, tl' x') xs)→*t " by simp_all
    from (s, tl, s')lset (LCons st stls). τmove s tl s' have "τmove s tl1 s1'" by simp
    moreover
    from IH[OF s1' -lappend stls (LCons (x, tl' x') xs)→*t ] (s, tl, s')lset (LCons st stls). τmove s tl s'
    have "s1' -τ→* x" by simp
    ultimately show ?thesis using s -tl1 s1' by(auto intro: converse_rtranclp_into_rtranclp)
  qed
qed


lemma inf_step_table_into_τinf_step:
  "s -stls→*t   s -τ-lmap (fst  snd) (lfilter (λ(s, tl, s'). ¬ τmove s tl s') stls)→* "
proof(coinduction arbitrary: s stls)
  case (τinf_step s stls)
  let ?P = "λ(s, tl, s'). ¬ τmove s tl s'"
  show ?case
  proof(cases "lfilter ?P stls")
    case LNil
    with τinf_step have ?τinf_step_Nil
      by(auto intro: inf_step_table_all_τ_into_τdiverge simp add: lfilter_eq_LNil)
    thus ?thesis ..
  next
    case (LCons stls' xs)
    obtain x tl x' where "stls' = (x, tl, x')" by(cases stls')
    with LCons have stls: "lfilter ?P stls = LCons (x, tl, x') xs" by simp
    from lfilter_eq_LConsD[OF this] obtain stls1 stls2
      where stls1: "stls = lappend stls1 (LCons (x, tl, x') stls2)"
      and "lfinite stls1"
      and τs: "(s, tl, s')lset stls1. τmove s tl s'"
      and: "¬ τmove x tl x'" and xs: "xs = lfilter ?P stls2" by blast
    from ‹lfinite stls1 τinf_step τs have "s -τ→* x" unfolding stls1
      by(rule inf_step_table_lappend_llist_of_τ_into_τmoves)
    moreover from ‹lfinite stls1 have "llist_of (list_of stls1) = stls1" by(simp add: llist_of_list_of)
    with τinf_step stls1 have "s -lappend (llist_of (list_of stls1)) (LCons (x, tl, x') stls2)→*t " by simp
    from inf_step_table_lappend_llist_ofD[OF this]
    have "x -LCons (x, tl, x') stls2→*t " ..
    hence "x -tl x'" "x' -stls2→*t " by(auto elim: inf_step_table.cases)
    ultimately have ?τinf_step_Cons using xs nτ by(auto simp add: stls o_def)
    thus ?thesis ..
  qed
qed

lemma inf_step_into_τinf_step:
  assumes "s -tls→* "
  shows "A. s -τ-lnths tls A→* "
proof -
  from inf_step_imp_inf_step_table[OF assms]
  obtain stls where "s -stls→*t " and tls: "tls = lmap (fst  snd) stls" by blast
  from s -stls→*t  have "s -τ-lmap (fst  snd) (lfilter (λ(s, tl, s'). ¬ τmove s tl s') stls)→* "
    by(rule inf_step_table_into_τinf_step)
  hence "s -τ-lnths tls {n. enat n < llength stls  (λ(s, tl, s'). ¬ τmove s tl s') (lnth stls n)}→* "
    unfolding lfilter_conv_lnths tls by simp
  thus ?thesis by blast
qed

lemma silent_moves_into_τrtrancl3p:
  "s -τ→* s'  s -τ-[]→* s'"
by(induct rule: converse_rtranclp_induct)(blast intro: τrtrancl3p.intros)+

lemma τrtrancl3p_into_silent_moves:
  "s -τ-[]→* s'  s -τ→* s'"
apply(induct s tls"[] :: 'tl list" s' rule: τrtrancl3p.induct)
apply(auto intro: converse_rtranclp_into_rtranclp)
done

lemma τrtrancl3p_Nil_eq_τmoves:
  "s -τ-[]→* s'  s -τ→* s'"
by(blast intro: silent_moves_into_τrtrancl3p τrtrancl3p_into_silent_moves)

lemma τrtrancl3p_trans [trans]:
  " s -τ-tls→* s'; s' -τ-tls'→* s''   s -τ-tls @ tls'→* s''"
apply(induct rule: τrtrancl3p.induct)
apply(auto intro: τrtrancl3p.intros)
done

lemma τrtrancl3p_SingletonE:
  fixes tl
  assumes red: "s -τ-[tl]→* s'''"
  obtains s' s'' where "s -τ→* s'" "s' -tl s''" "¬ τmove s' tl s''" "s'' -τ→* s'''"
proof(atomize_elim)
  from red show "s' s''. s -τ→* s'  s' -tl s''  ¬ τmove s' tl s''  s'' -τ→* s'''"
  proof(induct s tls"[tl]" s''')
    case (τrtrancl3p_step s s' s'')
    from s -tl s' ¬ τmove s tl s' s' -τ-[]→* s'' show ?case
      by(auto simp add: τrtrancl3p_Nil_eq_τmoves)
   next
    case (τrtrancl3p_τstep s s' s'' tl')
    then obtain t' t'' where "s' -τ→* t'" "t' -tl t''" "¬ τmove t' tl t''" "t'' -τ→* s''" by auto
    moreover
    from s -tl' s' τmove s tl' s' have "s -τ→* s'" by blast
    ultimately show ?case by(auto intro: rtranclp_trans)
  qed
qed

lemma τrtrancl3p_snocI:
  "tl.  τrtrancl3p s tls s''; s'' -τ→* s'''; s''' -tl s'; ¬ τmove s''' tl s' 
   τrtrancl3p s (tls @ [tl]) s'"
apply(erule τrtrancl3p_trans)
apply(fold τrtrancl3p_Nil_eq_τmoves)
apply(drule τrtrancl3p_trans)
 apply(erule (1) τrtrancl3p_step)
 apply(rule τrtrancl3p_refl)
apply simp
done

lemma τdiverge_rtranclp_silent_move:
  " silent_move^** s s'; s' -τ→    s -τ→ "
by(induct rule: converse_rtranclp_induct)(auto intro: τdivergeI)

lemma τdiverge_trancl_coinduct [consumes 1, case_names τdiverge]:
  assumes X: "X s"
  and step: "s. X s  s'. silent_move^++ s s'  (X s'  s' -τ→ )"
  shows "s -τ→ "
proof -
  from X have "s'. silent_move^** s s'  X s'" by blast
  thus ?thesis
  proof(coinduct)
    case (τdiverge s)
    then obtain s' where "silent_move** s s'" "X s'" by blast
    from step[OF X s'] obtain s'''
      where "silent_move^++ s' s'''" "X s'''  s''' -τ→ " by blast
    from ‹silent_move** s s' show ?case
    proof(cases rule: converse_rtranclpE[consumes 1, case_names refl step])
      case refl
      moreover from tranclpD[OF ‹silent_move^++ s' s'''] obtain s''
        where "silent_move s' s''" "silent_move^** s'' s'''" by blast
      ultimately show ?thesis using ‹silent_move^** s'' s''' X s'''  s''' -τ→ 
        by(auto intro: τdiverge_rtranclp_silent_move)
    next
      case (step S)
      moreover from ‹silent_move** S s' ‹silent_move^++ s' s'''
      have "silent_move^** S s'''" by(rule rtranclp_trans[OF _ tranclp_into_rtranclp])
      ultimately show ?thesis using X s'''  s''' -τ→  by(auto intro: τdiverge_rtranclp_silent_move)
    qed
  qed
qed

lemma τdiverge_trancl_measure_coinduct [consumes 2, case_names τdiverge]:
  assumes major: "X s t" "wfP μ"
  and step: "s t. X s t  s' t'. (μ t' t  s' = s  silent_move^++ s s')  (X s' t'  s' -τ→ )"
  shows "s -τ→ "
proof -
  { fix s t
    assume "X s t"
    with ‹wfP μ have "s' t'. silent_move^++ s s'  (X s' t'  s' -τ→ )"
    proof(induct arbitrary: s rule: wfP_induct[consumes 1])
      case (1 t)
      hence IH: "s' t'.  μ t' t; X s' t'  
                 s'' t''. silent_move^++ s' s''  (X s'' t''  s'' -τ→ )" by blast
      from step[OF X s t] obtain s' t'
        where "μ t' t  s' = s  silent_move++ s s'" "X s' t'  s' -τ→ " by blast
      from μ t' t  s' = s  silent_move++ s s' show ?case
      proof
        assume "μ t' t  s' = s"
        hence  "μ t' t" and [simp]: "s' = s" by simp_all
        from X s' t'  s' -τ→  show ?thesis
        proof
          assume "X s' t'"
          from IH[OF μ t' t this] show ?thesis by simp
        next
          assume "s' -τ→ " thus ?thesis
            by cases(auto simp add: silent_move_iff)
        qed
      next
        assume "silent_move++ s s'"
        thus ?thesis using X s' t'  s' -τ→  by blast
      qed
    qed }
  note X = this
  from X s t have "t. X s t" ..
  thus ?thesis
  proof(coinduct rule: τdiverge_trancl_coinduct)
    case (τdiverge s)
    then obtain t where "X s t" ..
    from X[OF this] show ?case by blast
  qed
qed

lemma τinf_step2τinf_step_table_LNil [simp]: "τinf_step2τinf_step_table s LNil = LNil"
by(simp add: τinf_step2τinf_step_table_def)

lemma τinf_step2τinf_step_table_LCons [simp]:
  fixes s tl ss tls
  defines "ss  SOME (s', s''). s -τ→* s'  s' -tl s''  ¬ τmove s' tl s''  s'' -τ-tls→* "
  shows
  "τinf_step2τinf_step_table s (LCons tl tls) =
   LCons (s, fst ss, tl, snd ss) (τinf_step2τinf_step_table (snd ss) tls)"
by(simp add: ss_def τinf_step2τinf_step_table_def split_beta)

lemma lnull_τinf_step2τinf_step_table [simp]:
  "lnull (τinf_step2τinf_step_table s tls)  lnull tls"
by(simp add: τinf_step2τinf_step_table_def)

lemma lhd_τinf_step2τinf_step_table [simp]:
  "¬ lnull tls  lhd (τinf_step2τinf_step_table s tls) = 
  (let (s', s'') = SOME (s', s''). s -τ→* s'  s' -lhd tls s''  ¬ τmove s' (lhd tls) s''  s'' -τ-ltl tls→* 
  in (s, s', lhd tls, s''))"
unfolding τinf_step2τinf_step_table_def Let_def by simp

lemma ltl_τinf_step2τinf_step_table [simp]:
  "¬ lnull tls  ltl (τinf_step2τinf_step_table s tls) =
  (let (s', s'') = SOME (s', s''). s -τ→* s'  s' -lhd tls s''  ¬ τmove s' (lhd tls) s''  s'' -τ-ltl tls→* 
  in τinf_step2τinf_step_table s'' (ltl tls))"
unfolding τinf_step2τinf_step_table_def Let_def
by(simp add: split_beta)

lemma lmap_τinf_step2τinf_step_table: "lmap (fst  snd  snd) (τinf_step2τinf_step_table s tls) = tls"
by(coinduction arbitrary: s tls)(auto simp add: split_beta)

lemma τinf_step_into_τinf_step_table:
  "s -τ-tls→*   s -τ-τinf_step2τinf_step_table s tls→*t "
proof(coinduction arbitrary: s tls)
  case (τinf_step_table s tls)
  thus ?case
  proof(cases)
    case (τinf_step_Cons s' s'' tls' tl)
    let ?ss = "SOME (s', s''). s -τ→* s'  s' -tl s''  ¬ τmove s' tl s''  s'' -τ-tls'→* "
    from τinf_step_Cons have tls: "tls = LCons tl tls'" and "s -τ→* s'" "s' -tl s''"
      "¬ τmove s' tl s''" "s'' -τ-tls'→* " by simp_all
    hence "(λ(s', s''). s -τ→* s'  s' -tl s''  ¬ τmove s' tl s''  s'' -τ-tls'→* ) (s', s'')" by simp
    hence "(λ(s', s''). s -τ→* s'  s' -tl s''  ¬ τmove s' tl s''  s'' -τ-tls'→* ) ?ss" by(rule someI)
    with tls have ?τinf_step_table_Cons by auto
    thus ?thesis ..
  next
    case τinf_step_Nil
    then have ?τinf_step_table_Nil by simp
    thus ?thesis ..
  qed
qed

lemma τinf_step_imp_τinf_step_table:
  assumes "s -τ-tls→* "
  shows "sstls. s -τ-sstls→*t   tls = lmap (fst  snd  snd) sstls"
using τinf_step_into_τinf_step_table[OF assms]
by(auto simp only: lmap_τinf_step2τinf_step_table)

lemma τinf_step_table_into_τinf_step:
  "s -τ-sstls→*t   s -τ-lmap (fst  snd  snd) sstls→* "
proof(coinduction arbitrary: s sstls)
  case (τinf_step s tls)
  thus ?case by cases(auto simp add: o_def)
qed

lemma silent_move_fromI [intro]:
  " silent_moves s0 s1; silent_move s1 s2   silent_move_from s0 s1 s2"
by(simp add: silent_move_from_def)

lemma silent_move_fromE [elim]:
  assumes "silent_move_from s0 s1 s2"
  obtains "silent_moves s0 s1" "silent_move s1 s2"
using assms by(auto simp add: silent_move_from_def)

lemma rtranclp_silent_move_from_imp_silent_moves:
  assumes s'x: "silent_move** s' x"
  shows "(silent_move_from s')^** x z  silent_moves s' z"
by(induct rule: rtranclp_induct)(auto intro: s'x)

lemma τdiverge_not_wfP_silent_move_from:
  assumes "s -τ→ "
  shows "¬ wfP (flip (silent_move_from s))"
proof
  assume "wfP (flip (silent_move_from s))"
  moreover define Q where "Q = {s'. silent_moves s s'  s' -τ→ }"
  hence "s  Q" using s -τ→  by(auto)
  ultimately have "zQ. y. silent_move_from s z y  y  Q"
    unfolding wfP_eq_minimal flip_simps by blast
  then obtain z where "z  Q"
    and min: "y. silent_move_from s z y  y  Q" by blast
  from z  Q have "silent_moves s z" "z -τ→ " unfolding Q_def by auto
  from z -τ→  obtain y where "silent_move z y" "y -τ→ " by cases auto
  from ‹silent_moves s z ‹silent_move z y have "silent_move_from s z y" ..
  hence "y  Q" by(rule min)
  moreover from ‹silent_moves s z ‹silent_move z y y -τ→ 
  have "y  Q" unfolding Q_def by auto
  ultimately show False by contradiction
qed

lemma wfP_silent_move_from_unroll:
  assumes wfPs': "s'. s -τ→ s'  wfP (flip (silent_move_from s'))"
  shows "wfP (flip (silent_move_from s))"
  unfolding wfP_eq_minimal flip_conv
proof(intro allI impI)
  fix Q and x :: 's
  assume "x  Q"
  show "zQ. y. silent_move_from s z y  y  Q"
  proof(cases "s'. s -τ→ s'  (x'. silent_moves s' x'  x'  Q)")
    case False
    hence "y. silent_move_from s x y  ¬ y  Q"
      by(cases "x=s")(auto, blast elim: converse_rtranclpE intro: rtranclp.rtrancl_into_rtrancl)
    with x  Q show ?thesis by blast
  next
    case True
    then obtain s' x' where "s -τ→ s'" and "silent_moves s' x'" and "x'  Q"
      by auto
    from s -τ→ s' have "wfP (flip (silent_move_from s'))" by(rule wfPs')
    from this x'  Q obtain z where "z  Q" and min: "y. silent_move_from s' z y  ¬ y  Q"
      and "(silent_move_from s')^** x' z"
      by (rule wfP_minimalE) (unfold flip_simps, blast)
    { fix y
      assume "silent_move_from s z y"
      with (silent_move_from s')^** x' z ‹silent_move^** s' x'
      have "silent_move_from s' z y"
        by(blast intro: rtranclp_silent_move_from_imp_silent_moves)
      hence "¬ y  Q" by(rule min) }
    with z  Q show ?thesis by(auto simp add: intro!: bexI)
  qed
qed

lemma not_wfP_silent_move_from_τdiverge:
  assumes "¬ wfP (flip (silent_move_from s))"
  shows "s -τ→ "
using assms
proof(coinduct)
  case (τdiverge s)
  { assume wfPs': "s'. s -τ→ s'  wfP (flip (silent_move_from s'))"
    hence "wfP (flip (silent_move_from s))" by(rule wfP_silent_move_from_unroll) }
  with τdiverge have "s'. s -τ→ s'  ¬ wfP (flip (silent_move_from s'))" by auto
  thus ?case by blast
qed

lemma τdiverge_neq_wfP_silent_move_from:
  "s -τ→   wfP (flip (silent_move_from s))"
by(auto intro: not_wfP_silent_move_from_τdiverge dest: τdiverge_not_wfP_silent_move_from)

lemma not_τdiverge_to_no_τmove:
  assumes "¬ s -τ→ "
  shows "s'. s -τ→* s'  (s''. ¬ s' -τ→ s'')"
proof -
  define S where "S = s"
  from ¬ τdiverge s have "wfP (flip (silent_move_from S))" unfolding S_def
    using τdiverge_neq_wfP_silent_move_from[of s] by simp
  moreover have "silent_moves S s" unfolding S_def ..
  ultimately show ?thesis
  proof(induct rule: wfP_induct')
    case (wfP s)
    note IH = y. flip (silent_move_from S) y s; S -τ→* y 
              s'. y -τ→* s'  (s''. ¬ s' -τ→ s'')
    show ?case
    proof(cases "s'. silent_move s s'")
      case False thus ?thesis by auto
    next
      case True
      then obtain s' where "s -τ→ s'" ..
      with S -τ→* s have "flip (silent_move_from S) s' s"
        unfolding flip_conv by(rule silent_move_fromI)
      moreover from S -τ→* s s -τ→ s' have "S -τ→* s'" ..
      ultimately have "s''. s' -τ→* s''  (s'''. ¬ s'' -τ→ s''')" by(rule IH)
      then obtain s'' where "s' -τ→* s''" "s'''. ¬ s'' -τ→ s'''" by blast
      from s -τ→ s' s' -τ→* s'' have "s -τ→* s''" by(rule converse_rtranclp_into_rtranclp)
      with s'''. ¬ s'' -τ→ s''' show ?thesis by blast
    qed
  qed
qed

lemma τdiverge_conv_τRuns:
  "s -τ→   s  TNil None"
by(auto intro: τRuns.Diverge elim: τRuns.cases)

lemma τinf_step_into_τRuns:
  "s -τ-tls→*   s  tllist_of_llist None tls"
proof(coinduction arbitrary: s tls)
  case (τRuns s tls')
  thus ?case by cases(auto simp add: τdiverge_conv_τRuns)
qed

lemma τ_into_τRuns:
  " s -τ→ s'; s'  tls   s  tls"
by(blast elim: τRuns.cases intro: τRuns.intros τdiverge.intros converse_rtranclp_into_rtranclp)

lemma τrtrancl3p_into_τRuns:
  assumes "s -τ-tls→* s'"
  and "s'  tls'"
  shows "s  lappendt (llist_of tls) tls'"
using assms
by induct(auto intro: τRuns.Proceed τ_into_τRuns)

lemma τRuns_table_into_τRuns:
  "τRuns_table s stlsss  s  tmap fst id stlsss"
proof(coinduction arbitrary: s stlsss)
  case (τRuns s tls)
  thus ?case by cases(auto simp add: o_def id_def)
qed

definition τRuns2τRuns_table :: "'s  ('tl, 's option) tllist  ('tl × 's, 's option) tllist"
where
  "τRuns2τRuns_table s tls = unfold_tllist
     (λ(s, tls). is_TNil tls)
     (λ(s, tls). terminal tls)
     (λ(s, tls). (thd tls, SOME s''. s'. s -τ→* s'  s' -thd tls s''  ¬ τmove s' (thd tls) s''  s''  ttl tls))
     (λ(s, tls). (SOME s''. s'. s -τ→* s'  s' -thd tls s''  ¬ τmove s' (thd tls) s''  s''  ttl tls, ttl tls))
     (s, tls)"

lemma is_TNil_τRuns2τRuns_table [simp]:
  "is_TNil (τRuns2τRuns_table s tls)  is_TNil tls"
  thm unfold_tllist.disc
by(simp add: τRuns2τRuns_table_def)

lemma thd_τRuns2τRuns_table [simp]:
  "¬ is_TNil tls 
  thd (τRuns2τRuns_table s tls) =
  (thd tls, SOME s''. s'. s -τ→* s'  s' -thd tls s''  ¬ τmove s' (thd tls) s''  s''  ttl tls)"
by(simp add: τRuns2τRuns_table_def)

lemma ttl_τRuns2τRuns_table [simp]:
  "¬ is_TNil tls 
  ttl (τRuns2τRuns_table s tls) =
  τRuns2τRuns_table (SOME s''. s'. s -τ→* s'  s' -thd tls s''  ¬ τmove s' (thd tls) s''  s''  ttl tls) (ttl tls)"
by(simp add: τRuns2τRuns_table_def)

lemma terminal_τRuns2τRuns_table [simp]:
  "is_TNil tls  terminal (τRuns2τRuns_table s tls) = terminal tls"
by(simp add: τRuns2τRuns_table_def)

lemma τRuns2τRuns_table_simps [simp, nitpick_simp]:
  "τRuns2τRuns_table s (TNil so) = TNil so"
  "tl. 
   τRuns2τRuns_table s (TCons tl tls) =
   (let s'' = SOME s''. s'. s -τ→* s'  s' -tl s''  ¬ τmove s' tl s''  s''  tls
    in TCons (tl, s'') (τRuns2τRuns_table s'' tls))"
 apply(simp add: τRuns2τRuns_table_def)
apply(rule tllist.expand)
apply(simp_all)
done

lemma τRuns2τRuns_table_inverse:
  "tmap fst id (τRuns2τRuns_table s tls) = tls"
by(coinduction arbitrary: s tls) auto
 
lemma τRuns_into_τRuns_table:
  assumes "s  tls"
  shows "stlsss. tls = tmap fst id stlsss  τRuns_table s stlsss"
proof(intro exI conjI)
  from assms show "τRuns_table s (τRuns2τRuns_table s tls)"
  proof(coinduction arbitrary: s tls)
    case (τRuns_table s tls)
    thus ?case
    proof cases
      case (Terminate s')
      hence ?Terminate by simp
      thus ?thesis ..
    next
      case Diverge
      hence ?Diverge by simp
      thus ?thesis by simp
    next
      case (Proceed s' s'' tls' tl)
      let ?P = "λs''. s'. s -τ→* s'  s' -tl s''  ¬ τmove s' tl s''  s''  tls'"
      from Proceed have "?P s''" by auto
      hence "?P (Eps ?P)" by(rule someI)
      hence ?Proceed using tls = TCons tl tls'
        by(auto simp add: split_beta)
      thus ?thesis by simp
    qed
  qed
qed(simp add: τRuns2τRuns_table_inverse)

lemma τRuns_lappendtE:
  assumes "σ  lappendt tls tls'"
  and "lfinite tls"
  obtains σ' where "σ -τ-list_of tls→* σ'"
  and "σ'  tls'"
proof(atomize_elim)
  from ‹lfinite tls σ  lappendt tls tls'
  show "σ'. σ -τ-list_of tls→* σ'  σ'  tls'"
  proof(induct arbitrary: σ)
    case lfinite_LNil thus ?case by(auto intro: τrtrancl3p_refl)
  next
    case (lfinite_LConsI tls tl)
    from σ  lappendt (LCons tl tls) tls'
    show ?case unfolding lappendt_LCons
    proof(cases)
      case (Proceed σ' σ'')
      from σ''  lappendt tls tls'  σ'''. σ'' -τ-list_of tls→* σ'''  σ'''  tls' σ''  lappendt tls tls'
      obtain σ''' where "σ'' -τ-list_of tls→* σ'''" "σ'''  tls'" by blast
      from σ' -tl σ'' ¬ τmove σ' tl σ'' σ'' -τ-list_of tls→* σ'''
      have "σ' -τ-tl # list_of tls→* σ'''" by(rule τrtrancl3p_step)
      with σ -τ→* σ' have "σ -τ-[] @ (tl # list_of tls)→* σ'''"
        unfolding τrtrancl3p_Nil_eq_τmoves[symmetric] by(rule τrtrancl3p_trans)
      with ‹lfinite tls have "σ -τ-list_of (LCons tl tls)→* σ'''" by(simp add: list_of_LCons)
      with σ'''  tls' show ?thesis by blast
    qed
  qed
qed

lemma τRuns_total:
  "tls. σ  tls"
proof
  let ?τhalt = "λσ σ'. σ -τ→* σ'  (tl σ''. ¬ σ' -tl σ'')"
  let ?τdiverge = "λσ. σ -τ→ "
  let ?proceed = "λσ (tl, σ''). σ'. σ -τ→* σ'  σ' -tl σ''  ¬ τmove σ' tl σ''"

  define tls where "tls = unfold_tllist
     (λσ. (σ'. ?τhalt σ σ')  ?τdiverge σ)
     (λσ. if σ'. ?τhalt σ σ' then Some (SOME σ'. ?τhalt σ σ') else None)
     (λσ. fst (SOME tlσ'. ?proceed σ tlσ'))
     (λσ. snd (SOME tlσ'. ?proceed σ tlσ')) σ"
  then show "σ  tls"
  proof(coinduct σ tls rule: τRuns.coinduct)
    case (τRuns σ tls)
    show ?case
    proof(cases "σ'. ?τhalt σ σ'")
      case True
      hence "?τhalt σ (SOME σ'. ?τhalt σ σ')" by(rule someI_ex)
      hence ?Terminate using True unfolding τRuns by simp
      thus ?thesis ..
    next
      case False
      note τhalt = this
      show ?thesis
      proof(cases "?τdiverge σ")
        case True
        hence ?Diverge using False unfolding τRuns by simp
        thus ?thesis by simp
      next
        case False
        from not_τdiverge_to_no_τmove[OF this]
        obtain σ' where σ_σ': "σ -τ→* σ'"
          and no_τ: "σ''. ¬ σ' -τ→ σ''" by blast
        from σ_σ' τhalt obtain tl σ'' where "σ' -tl σ''" by auto
        moreover with no_τ[of σ''] have "¬ τmove σ' tl σ''" by auto
        ultimately have "?proceed σ (tl, σ'')" using σ_σ' by auto
        hence "?proceed σ (SOME tlσ. ?proceed σ tlσ)" by(rule someI)
        hence ?Proceed using False τhalt unfolding τRuns
          by(subst unfold_tllist.code) fastforce
        thus ?thesis by simp
      qed
    qed
  qed
qed

lemma silent_move2_into_silent_move:
  fixes tl
  assumes "silent_move2 s tl s'"
  shows "s -τ→ s'"
using assms by(auto simp add: silent_move2_def)

lemma silent_move_into_silent_move2:
  assumes "s -τ→ s'"
  shows "tl. silent_move2 s tl s'"
using assms by(auto simp add: silent_move2_def)

lemma silent_moves2_into_silent_moves:
  assumes "silent_moves2 s tls s'"
  shows "s -τ→* s'"
using assms
by(induct)(blast intro: silent_move2_into_silent_move rtranclp.rtrancl_into_rtrancl)+

lemma silent_moves_into_silent_moves2:
  assumes "s -τ→* s'"
  shows "tls. silent_moves2 s tls s'"
using assms
by(induct)(blast dest: silent_move_into_silent_move2 intro: rtrancl3p_step)+

lemma inf_step_silent_move2_into_τdiverge:
  "trsys.inf_step silent_move2 s tls  s -τ→ "
proof(coinduction arbitrary: s tls)
  case (τdiverge s)
  thus ?case
    by(cases rule: trsys.inf_step.cases[consumes 1])(auto intro: silent_move2_into_silent_move)
qed

lemma τdiverge_into_inf_step_silent_move2:
  assumes "s -τ→ "
  obtains tls where "trsys.inf_step silent_move2 s tls"
proof -
  define tls where "tls = unfold_llist
     (λ_. False)
     (λs. fst (SOME (tl, s'). silent_move2 s tl s'  s' -τ→ ))
     (λs. snd (SOME (tl, s'). silent_move2 s tl s'  s' -τ→ ))
     s" (is "_ = ?tls s")
  
  with assms have "s -τ→   tls = ?tls s" by simp
  hence "trsys.inf_step silent_move2 s tls"
  proof(coinduct rule: trsys.inf_step.coinduct[consumes 1, case_names inf_step, case_conclusion inf_step step])
    case (inf_step s tls)
    let ?P = "λ(tl, s'). silent_move2 s tl s'  s' -τ→ "
    from inf_step obtain "s -τ→ " and tls: "tls = ?tls s" ..
    from s -τ→  obtain s' where "s -τ→ s'" "s' -τ→ " by cases
    from s -τ→ s' obtain tl where "silent_move2 s tl s'" 
      by(blast dest: silent_move_into_silent_move2)
    with s' -τ→  have "?P (tl, s')" by simp
    hence "?P (Eps ?P)" by(rule someI)
    thus ?case using tls
      by(subst (asm) unfold_llist.code)(auto)
  qed
  thus thesis by(rule that)
qed

lemma τRuns_into_τrtrancl3p:
  assumes runs: "s  tlss"
  and fin: "tfinite tlss"
  and terminal: "terminal tlss = Some s'"
  shows "τrtrancl3p s (list_of (llist_of_tllist tlss)) s'"
using fin runs terminal
proof(induct arbitrary: s rule: tfinite_induct)
  case TNil thus ?case by cases(auto intro: silent_moves_into_τrtrancl3p)
next
  case (TCons tl tlss)
  from s  TCons tl tlss obtain s'' s'''
    where step: "s -τ→* s''"
    and step2: "s'' -tl s'''" "¬ τmove s'' tl s'''" 
    and "s'''  tlss" by cases
  from ‹terminal (TCons tl tlss) = s' have "terminal tlss = s'" by simp
  with s'''  tlss have "s''' -τ-list_of (llist_of_tllist tlss)→* s'" by(rule TCons)
  with step2 have "s'' -τ-tl # list_of (llist_of_tllist tlss)→* s'" by(rule τrtrancl3p_step)
  with step have "s -τ-[] @ tl # list_of (llist_of_tllist tlss)→* s'"
    by(rule τrtrancl3p_trans[OF silent_moves_into_τrtrancl3p])
  thus ?case using ‹tfinite tlss by simp
qed

lemma τRuns_terminal_stuck:
  assumes Runs: "s  tlss"
  and fin: "tfinite tlss"
  and terminal: "terminal tlss = Some s'"
  and proceed: "s' -tls s''"
  shows False
using fin Runs terminal
proof(induct arbitrary: s rule: tfinite_induct)
  case TNil thus ?case using proceed by cases auto
next
  case TCons thus ?case by(fastforce elim: τRuns.cases)
qed

lemma Runs_table_silent_diverge:
  " Runs_table s stlss; (s, tl, s')  lset stlss. τmove s tl s'; ¬ lfinite stlss 
   s -τ→ "
proof(coinduction arbitrary: s stlss)
  case (τdiverge s)
  thus ?case by cases(auto 5 2)
qed

lemma Runs_table_silent_rtrancl:
  assumes "lfinite stlss"
  and "Runs_table s stlss"
  and "(s, tl, s')  lset stlss. τmove s tl s'"
  shows "s -τ→* llast (LCons s (lmap (λ(s, tl, s'). s') stlss))" (is ?thesis1)
  and "llast (LCons s (lmap (λ(s, tl, s'). s') stlss)) -tl' s''  False" (is "PROP ?thesis2")
proof -
  from assms have "?thesis1  (llast (LCons s (lmap (λ(s, tl, s'). s') stlss)) -tl' s''  False)"
  proof(induct arbitrary: s)
    case lfinite_LNil thus ?case by(auto elim: Runs_table.cases)
  next
    case (lfinite_LConsI stlss stls)
    from ‹Runs_table s (LCons stls stlss)
    obtain tl s' where [simp]: "stls = (s, tl, s')"
      and "s -tl s'" and Run': "Runs_table s' stlss" by cases
    from (s, tl, s')lset (LCons stls stlss). τmove s tl s'
    have "τmove s tl s'" and silent': "(s, tl, s')lset stlss. τmove s tl s'" by simp_all
    from s -tl s' τmove s tl s' have "s -τ→ s'" by auto
    moreover from Run' silent'
    have "s' -τ→* llast (LCons s' (lmap (λ(s, tl, s'). s') stlss)) 
          (llast (LCons s' (lmap (λ(s, tl, s'). s') stlss)) -tl' s''  False)"
      by(rule lfinite_LConsI)
    ultimately show ?case by(auto)
  qed
  thus ?thesis1 "PROP ?thesis2" by blast+
qed

lemma Runs_table_silent_lappendD:
  fixes s stlss
  defines "s'  llast (LCons s (lmap (λ(s, tl, s'). s') stlss))"
  assumes Runs: "Runs_table s (lappend stlss stlss')"
  and fin: "lfinite stlss"
  and silent: "(s, tl, s')  lset stlss. τmove s tl s'"
  shows "s -τ→* s'" (is ?thesis1)
  and "Runs_table s' stlss'" (is ?thesis2)
  and "stlss'  LNil  s' = fst (lhd stlss')" (is "PROP ?thesis3")
proof -
  from fin Runs silent
  have "?thesis1  ?thesis2  (stlss'  LNil  s' = fst (lhd stlss'))"
    unfolding s'_def
  proof(induct arbitrary: s)
    case lfinite_LNil thus ?case
      by(auto simp add: neq_LNil_conv Runs_table_simps)
  next
    case lfinite_LConsI thus ?case
      by(clarsimp simp add: neq_LNil_conv Runs_table_simps)(blast intro: converse_rtranclp_into_rtranclp)
  qed
  thus ?thesis1 ?thesis2 "PROP ?thesis3" by simp_all
qed

lemma Runs_table_into_τRuns:
  fixes s stlss
  defines "tls  tmap (λ(s, tl, s'). tl) id (tfilter None (λ(s, tl, s'). ¬ τmove s tl s') (tllist_of_llist (Some (llast (LCons s (lmap (λ(s, tl, s'). s') stlss)))) stlss))"
  (is "_  ?conv s stlss")
  assumes "Runs_table s stlss"
  shows "τRuns s tls"
using assms
proof(coinduction arbitrary: s tls stlss)
  case (τRuns s tls stlss)
  note tls = tls = ?conv s stlss
    and Run = ‹Runs_table s stlss
  show ?case
  proof(cases tls)
    case [simp]: (TNil so)
    from tls
    have silent: "(s, tl, s')  lset stlss. τmove s tl s'"
      by(auto simp add: TNil_eq_tmap_conv tfilter_empty_conv)
    show ?thesis
    proof(cases "lfinite stlss")
      case False
      with Run silent have "s -τ→ " by(rule Runs_table_silent_diverge)
      hence ?Diverge using False tls by(simp add: TNil_eq_tmap_conv tfilter_empty_conv)
      thus ?thesis by simp
    next
      case True
      with Runs_table_silent_rtrancl[OF this Run silent]
      have ?Terminate using tls
        by(auto simp add: TNil_eq_tmap_conv tfilter_empty_conv terminal_tllist_of_llist split_def)
      thus ?thesis by simp
    qed
  next
    case [simp]: (TCons tl tls')
    from tls obtain s' s'' stlss' 
      where tl': "tfilter None (λ(s, tl, s'). ¬ τmove s tl s') (tllist_of_llist llast (LCons s (lmap (λ(s, tl, s'). s') stlss)) stlss) = TCons (s', tl, s'') stlss'"
      and tls': "tls' = tmap (λ(s, tl, s'). tl) id stlss'"
      by(simp add: TCons_eq_tmap_conv split_def id_def split_paired_Ex) blast
    from tfilter_eq_TConsD[OF tl']
    obtain stlsτ rest
      where stlss_eq: "tllist_of_llist llast (LCons s (lmap (λ(s, tl, s'). s') stlss)) stlss = lappendt stlsτ (TCons (s', tl, s'') rest)"
      and fin: "lfinite stlsτ"
      and silent: "(s, tl, s')lset stlsτ. τmove s tl s'"
      and "¬ τmove s' tl s''"
      and stlss': "stlss' = tfilter None (λ(s, tl, s'). ¬ τmove s tl s') rest"
      by(auto simp add: split_def)
    from stlss_eq fin obtain rest'
      where stlss: "stlss = lappend stlsτ rest'"
      and rest': "tllist_of_llist llast (LCons s (lmap (λ(s, tl, s'). s') stlss)) rest' = TCons (s', tl, s'') rest"
      unfolding tllist_of_llist_eq_lappendt_conv by auto
    hence "rest'  LNil" by clarsimp
    from Run[unfolded stlss] fin silent
    have "s -τ→* llast (LCons s (lmap (λ(s, tl, s'). s') stlsτ))"
      and "Runs_table (llast (LCons s (lmap (λ(s, tl, s'). s') stlsτ))) rest'"
      and "llast (LCons s (lmap (λ(s, tl, s'). s') stlsτ)) = fst (lhd rest')"
      by(rule Runs_table_silent_lappendD)+(simp add: rest'  LNil›)
    moreover with rest' rest'  LNil› stlss fin obtain rest''
      where rest': "rest' = LCons (s', tl, s'') rest''"
      and rest: "rest = tllist_of_llist llast (LCons s'' (lmap (λ(s, tl, s'). s') rest'')) rest''"
      by(clarsimp simp add: neq_LNil_conv llast_LCons lmap_lappend_distrib)
    ultimately have "s -τ→* s'" "s' -tl s''" "Runs_table s'' rest''"
      by(simp_all add: Runs_table_simps)
    hence ?Proceed using ¬ τmove s' tl s'' tls' stlss' rest
      by(auto simp add: id_def)
    thus ?thesis by simp
  qed
qed

lemma τRuns_table2_into_τRuns:
  "τRuns_table2 s tlsstlss
   s  tmap (λ(tls, s', tl, s''). tl) (λx. case x of Inl (tls, s')  Some s' | Inr _  None) tlsstlss"
proof(coinduction arbitrary: s tlsstlss)
  case (τRuns s tlsstlss)
  thus ?case by cases(auto intro: silent_moves2_into_silent_moves inf_step_silent_move2_into_τdiverge)
qed

lemma τRuns_into_τRuns_table2:
  assumes "s  tls"
  obtains tlsstlss
  where "τRuns_table2 s tlsstlss"
  and "tls = tmap (λ(tls, s', tl, s''). tl) (λx. case x of Inl (tls, s')  Some s' | Inr _  None) tlsstlss"
proof -
  let ?terminal = "λs tls. case terminal tls of 
          None  Inr (SOME tls'. trsys.inf_step silent_move2 s tls')
        | Some s'  let tls' = SOME tls'. silent_moves2 s tls' s' in Inl (tls', s')"
  let ?P = "λs tls (tls'', s', s''). silent_moves2 s tls'' s'  s' -thd tls s''  ¬ τmove s' (thd tls) s''  s''  ttl tls"
  define tlsstlss where "tlsstlss s tls = unfold_tllist
      (λ(s, tls). is_TNil tls)
      (λ(s, tls). ?terminal s tls)
      (λ(s, tls). let (tls'', s', s'') = Eps (?P s tls) in (tls'', s', thd tls, s''))
      (λ(s, tls). let (tls'', s', s'') = Eps (?P s tls) in (s'', ttl tls))
      (s, tls)"
    for s tls

  have [simp]:
    "s tls. is_TNil (tlsstlss s tls)  is_TNil tls"
    "s tls. is_TNil tls  terminal (tlsstlss s tls) = ?terminal s tls"
    "s tls. ¬ is_TNil tls  thd (tlsstlss s tls) = (let (tls'', s', s'') = Eps (?P s tls) in (tls'', s', thd tls, s''))"
    "s tls. ¬ is_TNil tls  ttl (tlsstlss s tls) = (let (tls'', s', s'') = Eps (?P s tls) in tlsstlss s'' (ttl tls))"
    by(simp_all add: tlsstlss_def split_beta)

  have [simp]:
    "s. tlsstlss s (TNil None) = TNil (Inr (SOME tls'. trsys.inf_step silent_move2 s tls'))"
    "s s'. tlsstlss s (TNil (Some s')) = TNil (Inl (SOME tls'. silent_moves2 s tls' s', s'))"
    unfolding tlsstlss_def by simp_all

  let ?conv = "tmap (λ(tls, s', tl, s''). tl) (λx. case x of Inl (tls, s')  Some s' | Inr _  None)"
  from assms have "τRuns_table2 s (tlsstlss s tls)"
  proof(coinduction arbitrary: s tls)
    case (τRuns_table2 s tls)
    thus ?case
    proof(cases)
      case (Terminate s')
      let ?P = "λtls'. silent_moves2 s tls' s'"
      from s -τ→* s' obtain tls' where "?P tls'" by(blast dest: silent_moves_into_silent_moves2)
      hence "?P (Eps ?P)" by(rule someI)
      with Terminate have ?Terminate by auto
      thus ?thesis by simp
    next
      case Diverge
      let ?P = "λtls'. trsys.inf_step silent_move2 s tls'"
      from s -τ→  obtain tls' where "?P tls'" by(rule τdiverge_into_inf_step_silent_move2)
      hence "?P (Eps ?P)" by(rule someI)
      hence ?Diverge using tls = TNil None› by simp
      thus ?thesis by simp
    next
      case (Proceed s' s'' tls' tl)
      from s -τ→* s' obtain tls'' where "silent_moves2 s tls'' s'"
        by(blast dest: silent_moves_into_silent_moves2)
      with Proceed have "?P s tls (tls'', s', s'')" by simp
      hence "?P s tls (Eps (?P s tls))" by(rule someI)
      hence ?Proceed using Proceed unfolding tlsstlss_def
        by(subst unfold_tllist.code)(auto simp add: split_def)
      thus ?thesis by simp
    qed
  qed
  moreover
  from assms have "tls = ?conv (tlsstlss s tls)"
  proof(coinduction arbitrary: s tls)
    case (Eq_tllist s tls)
    thus ?case
    proof(cases)
      case (Proceed s' s'' tls' tl)
      from s -τ→* s' obtain tls'' where "silent_moves2 s tls'' s'"
        by(blast dest: silent_moves_into_silent_moves2)
      with Proceed have "?P s tls (tls'', s', s'')" by simp
      hence "?P s tls (Eps (?P s tls))" by(rule someI)
      thus ?thesis using tls = TCons tl tls' by auto
    qed auto
  qed
  ultimately show thesis by(rule that)
qed

lemma τRuns_table2_into_Runs:
  assumes "τRuns_table2 s tlsstlss"
  shows "Runs s (lconcat (lappend (lmap (λ(tls, s, tl, s'). llist_of (tls @ [tl])) (llist_of_tllist tlsstlss)) (LCons (case terminal tlsstlss of Inl (tls, s')  llist_of tls | Inr tls  tls) LNil)))"
  (is "Runs _ (?conv tlsstlss)")
using assms
proof(coinduction arbitrary: s tlsstlss)
  case (Runs s tlsstlss)
  thus ?case
  proof(cases)
    case (Terminate tls' s')
    from ‹silent_moves2 s tls' s' show ?thesis
    proof(cases rule: rtrancl3p_converseE)
      case refl 
      hence ?Stuck using Terminate by simp
      thus ?thesis ..
    next
      case (step tls'' tl s'')
      from ‹silent_moves2 s'' tls'' s' tl s''. ¬ s' -tl s''
      have "τRuns_table2 s'' (TNil (Inl (tls'', s')))" ..
      with tls' = tl # tls'' ‹silent_move2 s tl s'' tlsstlss = TNil (Inl (tls', s'))
      have ?Step by(auto simp add: silent_move2_def intro!: exI)
      thus ?thesis ..
    qed
  next
    case (Diverge tls')
    from ‹trsys.inf_step silent_move2 s tls'
    obtain tl tls'' s' where "silent_move2 s tl s'" 
      and "tls' = LCons tl tls''" "trsys.inf_step silent_move2 s' tls''"
      by(cases rule: trsys.inf_step.cases[consumes 1]) auto
    from ‹trsys.inf_step silent_move2 s' tls''
    have "τRuns_table2 s' (TNil (Inr tls''))" ..
    hence ?Step using tlsstlss = TNil (Inr tls') tls' = LCons tl tls'' ‹silent_move2 s tl s'
      by(auto simp add: silent_move2_def intro!: exI)
    thus ?thesis ..
  next
    case (Proceed tls' s' s'' tlsstlss' tl)
    from ‹silent_moves2 s tls' s' have ?Step
    proof(cases rule: rtrancl3p_converseE)
      case refl with Proceed show ?thesis by auto
    next
      case (step tls'' tl' s''')
      from ‹silent_moves2 s''' tls'' s' s' -tl s'' ¬ τmove s' tl s'' ‹τRuns_table2 s'' tlsstlss'
      have "τRuns_table2 s''' (TCons (tls'', s', tl, s'') tlsstlss')" ..
      with tls' = tl' # tls'' ‹silent_move2 s tl' s''' tlsstlss = TCons (tls', s', tl, s'') tlsstlss'
      show ?thesis by(auto simp add: silent_move2_def intro!: exI)
    qed
    thus ?thesis ..
  qed
qed

lemma τRuns_table2_silentsD:
  fixes tl
  assumes Runs: "τRuns_table2 s tlsstlss"
  and tset: "(tls, s', tl', s'')  tset tlsstlss"
  and set: "tl  set tls"
  shows "s''' s''''. silent_move2 s''' tl s''''"
using tset Runs
proof(induct arbitrary: s rule: tset_induct)
  case (find tlsstlss')
  from ‹τRuns_table2 s (TCons (tls, s', tl', s'') tlsstlss')
  have "silent_moves2 s tls s'" by cases
  thus ?case using set by induct auto
next
  case step thus ?case by(auto simp add: τRuns_table2_simps)
qed

lemma τRuns_table2_terminal_silentsD:
  assumes Runs: "τRuns_table2 s tlsstlss"
  and fin: "lfinite (llist_of_tllist tlsstlss)"
  and terminal: "terminal tlsstlss = Inl (tls, s'')"
  shows "s'. silent_moves2 s' tls s''"
using fin Runs terminal
proof(induct "llist_of_tllist tlsstlss" arbitrary: tlsstlss s)
  case lfinite_LNil thus ?case 
    by(cases tlsstlss)(auto simp add: τRuns_table2_simps)
next
  case (lfinite_LConsI xs tlsstls)
  thus ?case by(cases tlsstlss)(auto simp add: τRuns_table2_simps)
qed

lemma τRuns_table2_terminal_inf_stepD:
  assumes Runs: "τRuns_table2 s tlsstlss"
  and fin: "lfinite (llist_of_tllist tlsstlss)"
  and terminal: "terminal tlsstlss = Inr tls"
  shows "s'. trsys.inf_step silent_move2 s' tls"
using fin Runs terminal
proof(induct "llist_of_tllist tlsstlss" arbitrary: s tlsstlss)
  case lfinite_LNil thus ?case
    by(cases tlsstlss)(auto simp add: τRuns_table2_simps)
next
  case (lfinite_LConsI xs tlsstls)
  thus ?case by(cases tlsstlss)(auto simp add: τRuns_table2_simps)
qed

lemma τRuns_table2_lappendtD:
  assumes Runs: "τRuns_table2 s (lappendt tlsstlss tlsstlss')"
  and fin: "lfinite tlsstlss"
  shows "s'. τRuns_table2 s' tlsstlss'"
using fin Runs
by(induct arbitrary: s)(auto simp add: τRuns_table2_simps)

end

lemma τmoves_False: "τtrsys.silent_move r (λs ta s'. False) = (λs s'. False)"
by(auto simp add: τtrsys.silent_move_iff)

lemma τrtrancl3p_False_eq_rtrancl3p: "τtrsys.τrtrancl3p r (λs tl s'. False) = rtrancl3p r"
proof(intro ext iffI)
  fix s tls s'
  assume "τtrsys.τrtrancl3p r (λs tl s'. False) s tls s'"
  thus "rtrancl3p r s tls s'" by(rule τtrsys.τrtrancl3p.induct)(blast intro: rtrancl3p_step_converse)+
next
  fix s tls s'
  assume "rtrancl3p r s tls s'"
  thus "τtrsys.τrtrancl3p r (λs tl s'. False) s tls s'"
    by(induct rule: rtrancl3p_converse_induct)(auto intro: τtrsys.τrtrancl3p.intros)
qed

lemma τdiverge_empty_τmove:
  "τtrsys.τdiverge r (λs ta s'. False) = (λs. False)"
by(auto intro!: ext elim: τtrsys.τdiverge.cases τtrsys.silent_move.cases)

end

Theory FWLTS

(*  Title:      JinjaThreads/Framework/FWLTS.thy
    Author:     Andreas Lochbihler
*)

section ‹The multithreaded semantics as a labelled transition system›

theory FWLTS
imports
  FWProgressAux
  FWLifting
  LTS
begin

sublocale multithreaded_base < trsys "r t" for t .
sublocale multithreaded_base < mthr: trsys redT .

― ‹Move to FWSemantics?›
definition redT_upd_ε :: "('l,'t,'x,'m,'w) state  't  'x  'm  ('l,'t,'x,'m,'w) state"
where [simp]: "redT_upd_ε s t x' m' = (locks s, ((thr s)(t  (x', snd (the (thr s t)))), m'), wset s, interrupts s)"

lemma redT_upd_ε_redT_upd:
  "redT_upd s t ε x' m' (redT_upd_ε s t x' m')"
by(auto simp add: redT_updLns_def redT_updWs_def)

context multithreaded begin
  
sublocale trsys "r t" for t .
    
sublocale mthr: trsys redT .
    
end
  
subsection ‹The multithreaded semantics with internal actions›

type_synonym
  ('l,'t,'x,'m,'w,'o) τmoves =
    "'x × 'm  ('l,'t,'x,'m,'w,'o) thread_action  'x × 'm  bool"

text ‹pretty printing for τmoves›
print_translation let
    fun tr' [(Const (@{type_syntax "prod"}, _) $ x1 $ m1),
             (Const (@{type_syntax "fun"}, _) $
               (Const (@{type_syntax "prod"}, _) $ 
                 (Const (@{type_syntax "finfun"}, _) $ l $ 
                   (Const (@{type_syntax "list"}, _) $ Const (@{type_syntax "lock_action"}, _))) $
                 (Const (@{type_syntax "prod"},_) $ 
                   (Const (@{type_syntax "list"}, _) $ (Const (@{type_syntax "new_thread_action"}, _) $ t1 $ x2 $ m2)) $
                   (Const (@{type_syntax "prod"}, _) $ 
                     (Const (@{type_syntax "list"}, _) $ (Const (@{type_syntax "conditional_action"}, _) $ t2)) $
                     (Const (@{type_syntax "prod"}, _) $ 
                       (Const (@{type_syntax "list"}, _) $ (Const (@{type_syntax "wait_set_action"}, _) $ t3 $ w)) $
                       (Const (@{type_syntax prod}, _) $ 
                         (Const (@{type_syntax list}, _) $ (Const (@{type_syntax "interrupt_action"}, _) $ t4)) $
                         (Const (@{type_syntax "list"}, _) $ o1)))))) $
               (Const (@{type_syntax "fun"}, _) $ 
                 (Const (@{type_syntax "prod"}, _) $ x3 $ m3) $
                 (Const (@{type_syntax "bool"}, _))))] =
      if x1 = x2 andalso x1 = x3 andalso m1 = m2 andalso m1 = m3 andalso t1 = t2 andalso t2 = t3 andalso t3 = t4
      then Syntax.const (@{type_syntax "τmoves"}) $ l $ t1 $ x1 $ m1 $ w $ o1
      else raise Match;
  in [(@{type_syntax "fun"}, K tr')]
  end
typ "('l,'t,'x,'m,'w,'o) τmoves"

locale τmultithreaded = multithreaded_base +
  constrains final :: "'x  bool"
  and r :: "('l,'t,'x,'m,'w,'o) semantics"
  and convert_RA :: "'l released_locks  'o list"
  fixes τmove :: "('l,'t,'x,'m,'w,'o) τmoves"

sublocale τmultithreaded < τtrsys "r t" τmove for t .

context τmultithreaded begin

inductive mτmove :: "(('l,'t,'x,'m,'w) state, 't × ('l,'t,'x,'m,'w,'o) thread_action) trsys"
where
  " thr s t = (x, no_wait_locks); thr s' t = (x', ln'); τmove (x, shr s) ta (x', shr s') 
   mτmove s (t, ta) s'"

end

sublocale τmultithreaded < mthr: τtrsys redT mτmove .

context τmultithreaded begin

abbreviation τmredT :: "('l,'t,'x,'m,'w) state  ('l,'t,'x,'m,'w) state  bool"
where "τmredT == mthr.silent_move"

end

lemma (in multithreaded_base) τrtrancl3p_redT_thread_not_disappear:
  assumes "τtrsys.τrtrancl3p redT τmove s ttas s'" "thr s t  None"
  shows "thr s' t  None"
proof -
  interpret T: τtrsys redT τmove .
  show ?thesis
  proof
    assume "thr s' t = None"
    with ‹τtrsys.τrtrancl3p redT τmove s ttas s' have "thr s t = None"
      by(induct rule: T.τrtrancl3p.induct)(auto simp add: split_paired_all dest: redT_thread_not_disappear)
    with ‹thr s t  None› show False by contradiction
  qed
qed

lemma mτmove_False: "τmultithreaded.mτmove (λs ta s'. False) = (λs ta s'. False)"
by(auto intro!: ext elim: τmultithreaded.mτmove.cases)

declare split_paired_Ex [simp del]

locale τmultithreaded_wf =
  τmultithreaded _ _ _ τmove +
  multithreaded final r convert_RA
  for τmove :: "('l,'t,'x,'m,'w,'o) τmoves" +
  assumes τmove_heap: " t  (x, m) -ta (x', m'); τmove (x, m) ta (x', m')   m = m'"
  assumes silent_tl: "τmove s ta s'  ta = ε"
begin

lemma mτmove_silentD: "mτmove s (t, ta) s'  ta = (K$ [], [], [], [], [], [])"
by(auto elim!: mτmove.cases dest: silent_tl)

lemma mτmove_heap: 
  assumes redT: "redT s (t, ta) s'"
  and mτmove: "mτmove s (t, ta) s'"
  shows "shr s' = shr s"
using mτmove redT
by cases(auto dest: τmove_heap elim!: redT.cases)

lemma τmredT_thread_preserved:
  "τmredT s s'  thr s t = None  thr s' t = None"
by(auto simp add: mthr.silent_move_iff elim!: redT.cases dest!: mτmove_silentD split: if_split_asm)

lemma τmRedT_thread_preserved:
  "τmredT^** s s'  thr s t = None  thr s' t = None"
by(induct rule: rtranclp.induct)(auto dest: τmredT_thread_preserved[where t=t])

lemma τmtRedT_thread_preserved:
  "τmredT^++ s s'  thr s t = None  thr s' t = None"
by(induct rule: tranclp.induct)(auto dest: τmredT_thread_preserved[where t=t])

lemma τmredT_add_thread_inv:
  assumes τred: "τmredT s s'" and tst: "thr s t = None"
  shows "τmredT (locks s, ((thr s)(t  xln), shr s), wset s, interrupts s) (locks s', ((thr s')(t  xln), shr s'), wset s', interrupts s')"
proof -
  obtain ls ts m ws "is" where s: "s = (ls, (ts, m), ws, is)" by(cases s) fastforce
  obtain ls' ts' m' ws' is' where s': "s' = (ls', (ts', m'), ws', is')" by(cases s') fastforce
  from τred s s' obtain t' where red: "(ls, (ts, m), ws, is) -t'ε (ls', (ts', m'), ws', is')"
    and τ: "mτmove (ls, (ts, m), ws, is) (t', ε) (ls', (ts', m'), ws', is')"
    by(auto simp add: mthr.silent_move_iff dest: mτmove_silentD)
  from red have "(ls, (ts(t  xln), m), ws, is) -t'ε (ls', (ts'(t  xln), m'), ws', is')"
  proof(cases rule: redT_elims)
    case (normal x x' m') with tst s show ?thesis
      by-(rule redT_normal, auto simp add: fun_upd_twist elim!: rtrancl3p_cases)
  next
    case (acquire x ln n)
    with tst s show ?thesis
      unfolding ε = (K$ [], [], [], [], [], convert_RA ln)
      by -(rule redT_acquire, auto intro: fun_upd_twist)
  qed
  moreover from red tst s have tt': "t  t'" by(cases) auto
  have "(λt''. (ts(t  xln)) t''  None  (ts(t  xln)) t''  (ts'(t  xln)) t'') =
        (λt''. ts t''  None  ts t''  ts' t'')" using tst s by(auto simp add: fun_eq_iff)
  with τ tst tt' have "mτmove (ls, (ts(t  xln), m), ws, is) (t', ε) (ls', (ts'(t  xln), m'), ws', is')"
    by cases(rule mτmove.intros, auto)
  ultimately show ?thesis unfolding s s' by auto
qed

lemma τmRedT_add_thread_inv:
  " τmredT^** s s'; thr s t = None 
   τmredT^** (locks s, ((thr s)(t  xln), shr s), wset s, interrupts s) (locks s', ((thr s')(t  xln), shr s'), wset s', interrupts s')"
apply(induct rule: rtranclp_induct)
apply(blast dest: τmRedT_thread_preserved[where t=t] τmredT_add_thread_inv[where xln=xln] intro: rtranclp.rtrancl_into_rtrancl)+
done

lemma τmtRed_add_thread_inv:
  " τmredT^++ s s'; thr s t = None 
   τmredT^++ (locks s, ((thr s)(t  xln), shr s), wset s, interrupts s) (locks s', ((thr s')(t  xln), shr s'), wset s', interrupts s')"
apply(induct rule: tranclp_induct)
apply(blast dest: τmtRedT_thread_preserved[where t=t] τmredT_add_thread_inv[where xln=xln] intro: tranclp.trancl_into_trancl)+
done

lemma silent_move_into_RedT_τ_inv:
  assumes move: "silent_move t (x, shr s) (x', m')"
  and state: "thr s t = (x, no_wait_locks)" "wset s t = None"
  shows "τmredT s (redT_upd_ε s t x' m')"
proof -
  from move obtain red: "t  (x, shr s) -ε (x', m')" and τ: "τmove (x, shr s) ε (x', m')"
    by(auto simp add: silent_move_iff dest: silent_tl)
  from red state have "s -tε redT_upd_ε s t x' m'"
    by -(rule redT_normal, auto simp add: redT_updLns_def o_def finfun_Diag_const2 redT_updWs_def)
  moreover from τ red state have "mτmove s (t, ε) (redT_upd_ε s t x' m')"
    by -(rule mτmove.intros, auto dest: τmove_heap simp add: redT_updLns_def)
  ultimately show ?thesis by auto
qed

lemma silent_moves_into_RedT_τ_inv:
  assumes major: "silent_moves t (x, shr s) (x', m')"
  and state: "thr s t = (x, no_wait_locks)" "wset s t = None"
  shows "τmredT^** s (redT_upd_ε s t x' m')"
using major
proof(induct rule: rtranclp_induct2)
  case refl with state show ?case by(cases s)(auto simp add: fun_upd_idem)
next
  case (step x' m' x'' m'')
  from ‹silent_move t (x', m') (x'', m'') state
  have "τmredT (redT_upd_ε s t x' m') (redT_upd_ε (redT_upd_ε s t x' m') t x'' m'')"
    by -(rule silent_move_into_RedT_τ_inv, auto)
  hence "τmredT (redT_upd_ε s t x' m') (redT_upd_ε s t x'' m'')" by(simp)
  with ‹τmredT^** s (redT_upd_ε s t x' m') show ?case ..
qed

lemma red_rtrancl_τ_heapD_inv:
  " silent_moves t s s'; wfs t s   snd s' = snd s"
proof(induct rule: rtranclp_induct)
  case base show ?case ..
next
  case (step s' s'')
  thus ?case by(cases s, cases s', cases s'')(auto dest: τmove_heap)
qed

lemma red_trancl_τ_heapD_inv:
  " silent_movet t s s'; wfs t s   snd s' = snd s"
proof(induct rule: tranclp_induct)
  case (base s') thus ?case by(cases s')(cases s, auto simp add: silent_move_iff dest: τmove_heap)
next
  case (step s' s'')
  thus ?case by(cases s, cases s', cases s'')(auto simp add: silent_move_iff dest: τmove_heap)
qed

lemma red_trancl_τ_into_RedT_τ_inv:
  assumes major: "silent_movet t (x, shr s) (x', m')"
  and state: "thr s t = (x, no_wait_locks)" "wset s t = None"
  shows "τmredT^++ s (redT_upd_ε s t x' m')"
using major
proof(induct rule: tranclp_induct2)
  case (base x' m')
  thus ?case using state
    by -(rule tranclp.r_into_trancl, rule silent_move_into_RedT_τ_inv, auto)
next
  case (step x' m' x'' m'')
  hence "τmredT^++ s (redT_upd_ε s t x' m')" by blast
  moreover from ‹silent_move t (x', m') (x'', m'') state
  have "τmredT (redT_upd_ε s t x' m') (redT_upd_ε (redT_upd_ε s t x' m') t x'' m'')"
    by -(rule silent_move_into_RedT_τ_inv, auto simp add: redT_updLns_def)
  hence "τmredT (redT_upd_ε s t x' m') (redT_upd_ε s t x'' m'')"
    by(simp add: redT_updLns_def)
  ultimately show ?case ..
qed

lemma τdiverge_into_τmredT:
  assumes "τdiverge t (x, shr s)"
  and "thr s t = (x, no_wait_locks)" "wset s t = None"
  shows "mthr.τdiverge s"
using assms
proof(coinduction arbitrary: s x)
  case (τdiverge s x)
  note tst = ‹thr s t = (x, no_wait_locks)
  from ‹τdiverge t (x, shr s) obtain x' m' where "silent_move t (x, shr s) (x', m')" 
    and "τdiverge t (x', m')" by cases auto
  from ‹silent_move t (x, shr s) (x', m') tst ‹wset s t = None›
  have "τmredT s (redT_upd_ε s t x' m')" by(rule silent_move_into_RedT_τ_inv)
  moreover have "thr (redT_upd_ε s t x' m') t = (x', no_wait_locks)"
    using tst by(auto simp add: redT_updLns_def)
  moreover have "wset (redT_upd_ε s t x' m') t = None" using ‹wset s t = None› by simp
  moreover from ‹τdiverge t (x', m') have "τdiverge t (x', shr (redT_upd_ε s t x' m'))" by simp
  ultimately show ?case using ‹τdiverge t (x', m') by blast
qed

lemma τdiverge_τmredTD:
  assumes div: "mthr.τdiverge s"
  and fin: "finite (dom (thr s))"
  shows "t x. thr s t = (x, no_wait_locks)  wset s t = None  τdiverge t (x, shr s)"
using fin div
proof(induct A"dom (thr s)" arbitrary: s rule: finite_induct)
  case empty
  from ‹mthr.τdiverge s obtain s' where "τmredT s s'" by cases auto
  with {} = dom (thr s)[symmetric] have False by(auto elim!: mthr.silent_move.cases redT.cases)
  thus ?case ..
next
  case (insert t A)
  note IH = s.  A = dom (thr s); mthr.τdiverge s 
              t x. thr s t = (x, no_wait_locks)  wset s t = None  τdiverge t (x, shr s)
  from ‹insert t A = dom (thr s)
  obtain x ln where tst: "thr s t = (x, ln)" by(fastforce simp add: dom_def)
  define s' where "s' = (locks s, ((thr s)(t := None), shr s), wset s, interrupts s)"
  show ?case
  proof(cases "ln = no_wait_locks  τdiverge t (x, shr s)  wset s t = None")
    case True
    with tst show ?thesis by blast
  next
    case False
    define xm where "xm = (x, shr s)"
    define xm' where "xm' = (x, shr s)"
    have "A = dom (thr s')" using t  A ‹insert t A = dom (thr s)
      unfolding s'_def by auto
    moreover { 
      from xm'_def tst ‹mthr.τdiverge s False
      have "s x. thr s t = (x, ln)  (ln  no_wait_locks  wset s t  None  ¬ τdiverge t xm') 
                  s' = (locks s, ((thr s)(t := None), shr s), wset s, interrupts s)  xm = (x, shr s)  
                  mthr.τdiverge s  silent_moves t xm' xm"
        unfolding s'_def xm_def by blast
      moreover
      from False have "wfP (if τdiverge t xm' then (λs s'. False) else flip (silent_move_from t xm'))"
        using τdiverge_neq_wfP_silent_move_from[of t "(x, shr s)"] unfolding xm'_def by(auto)
      ultimately have "mthr.τdiverge s'"
      proof(coinduct s' xm rule: mthr.τdiverge_trancl_measure_coinduct)
        case (τdiverge s' xm)
        then obtain s x where tst: "thr s t = (x, ln)"
          and blocked: "ln  no_wait_locks  wset s t  None  ¬ τdiverge t xm'"
          and s'_def: "s' = (locks s, ((thr s)(t := None), shr s), wset s, interrupts s)"
          and xm_def: "xm = (x, shr s)"
          and xmxm': "silent_moves t xm' (x, shr s)"
          and "mthr.τdiverge s" by blast
        from ‹mthr.τdiverge s obtain s'' where "τmredT s s''" "mthr.τdiverge s''" by cases auto
        from ‹τmredT s s'' obtain t' ta where "s -t'ta s''" and "mτmove s (t', ta) s''" by auto
        then obtain x' x'' m'' where red: "t'  x', shr s -ta x'', m''"
          and tst': "thr s t' = (x', no_wait_locks)" 
          and aoe: "actions_ok s t' ta"
          and s'': "redT_upd s t' ta x'' m'' s''"
          by cases(fastforce elim: mτmove.cases)+
        from ‹mτmove s (t', ta) s'' have [simp]: "ta = ε"
          by(auto elim!: mτmove.cases dest!: silent_tl)
        hence wst': "wset s t' = None" using aoe by auto
        from ‹mτmove s (t', ta) s'' tst' s''
        have "τmove (x', shr s) ε (x'', m'')" by(auto elim: mτmove.cases)
        show ?case
        proof(cases "t' = t")
          case False
          with tst' wst' have "thr s' t' = (x', no_wait_locks)"
            "wset s' t' = None" "shr s' = shr s" unfolding s'_def by auto
          with red have "s' -t'ε redT_upd_ε s' t' x'' m''"
            by -(rule redT_normal, auto simp add: redT_updLns_def o_def finfun_Diag_const2 redT_updWs_def)
          moreover from τmove (x', shr s) ε (x'', m'') ‹thr s' t' = (x', no_wait_locks) ‹shr s' = shr s
          have "mτmove s' (t', ta) (redT_upd_ε s' t' x'' m'')"
            by -(rule mτmove.intros, auto)
          ultimately have "τmredT s' (redT_upd_ε s' t' x'' m'')"
            unfolding ta = ε by(rule mthr.silent_move.intros)
          hence "τmredT^++ s' (redT_upd_ε s' t' x'' m'')" ..
          moreover have "thr s'' t = (x, ln)"
            using tst t'  t s'' by auto
          moreover from τmove (x', shr s) ε (x'', m'') red
          have [simp]: "m'' = shr s" by(auto dest: τmove_heap)
          hence "shr s = shr s''" using s'' by(auto)
          have "ln  no_wait_locks  wset s'' t  None  ¬ τdiverge t xm'"
            using blocked s'' by(auto simp add: redT_updWs_def elim!: rtrancl3p_cases)
          moreover have "redT_upd_ε s' t' x'' m'' = (locks s'', ((thr s'')(t := None), shr s''), wset s'', interrupts s'')"
            unfolding s'_def using tst s'' t'  t
            by(auto intro: ext elim!: rtrancl3p_cases simp add: redT_updLns_def redT_updWs_def)
          ultimately show ?thesis using ‹mthr.τdiverge s'' xmxm'
            unfolding ‹shr s = shr s'' by blast
        next
          case True
          with tst tst' wst' blocked have "¬ τdiverge t xm'"
            and [simp]: "x' = x" by auto
          moreover from red τmove (x', shr s) ε (x'', m'') True
          have "silent_move t (x, shr s) (x'', m'')" by auto
          with xmxm' have "silent_move_from t xm' (x, shr s) (x'', m'')"
            by(rule silent_move_fromI)
          ultimately have "(if τdiverge t xm' then λs s'. False else flip (silent_move_from t xm')) (x'', m'') xm"
            by(auto simp add: flip_conv xm_def)
          moreover have "thr s'' t = (x'', ln)" using tst True s''
            by(auto simp add: redT_updLns_def)
          moreover from τmove (x', shr s) ε (x'', m'') red
          have [simp]: "m'' = shr s" by(auto dest: τmove_heap)
          hence "shr s = shr s''" using s'' by auto
          have "s' = (locks s'', ((thr s'')(t := None), shr s''), wset s'', interrupts s'')"
            using True s'' unfolding s'_def 
            by(auto intro: ext elim!: rtrancl3p_cases simp add: redT_updLns_def redT_updWs_def)
          moreover have "(x'', m'') = (x'', shr s'')" using s'' by auto
          moreover from xmxm' ‹silent_move t (x, shr s) (x'', m'')
          have "silent_moves t xm' (x'', shr s'')"
            unfolding m'' = shr s ‹shr s = shr s'' by auto
          ultimately show ?thesis using ¬ τdiverge t xm' ‹mthr.τdiverge s'' by blast
        qed
      qed }
    ultimately have "t x. thr s' t = (x, no_wait_locks)  wset s' t = None  τdiverge t (x, shr s')" by(rule IH)
    then obtain t' x' where "thr s' t' = (x', no_wait_locks)"
      and "wset s' t' = None" and "τdiverge t' (x', shr s')" by blast
    moreover with False have "t'  t" by(auto simp add: s'_def)
    ultimately have "thr s t' = (x', no_wait_locks)" "wset s t' = None" "τdiverge t' (x', shr s)"
      unfolding s'_def by auto
    thus ?thesis by blast
  qed
qed

lemma τmredT_preserves_final_thread:
  " τmredT s s'; final_thread s t   final_thread s' t"
by(auto elim: mthr.silent_move.cases intro: redT_preserves_final_thread)

lemma τmRedT_preserves_final_thread:
  " τmredT^** s s'; final_thread s t   final_thread s' t"
by(induct rule: rtranclp.induct)(blast intro: τmredT_preserves_final_thread)+

lemma silent_moves2_silentD:
  assumes "rtrancl3p mthr.silent_move2 s ttas s'"
  and "(t, ta)  set ttas"
  shows "ta = ε"
using assms
by(induct)(auto simp add: mthr.silent_move2_def dest: mτmove_silentD)

lemma inf_step_silentD:
  assumes step: "trsys.inf_step mthr.silent_move2 s ttas"
  and lset: "(t, ta)  lset ttas"
  shows "ta = ε"
using lset step
by(induct arbitrary: s rule: lset_induct)(fastforce elim: trsys.inf_step.cases simp add: mthr.silent_move2_def dest: mτmove_silentD)+

end

subsection ‹The multithreaded semantics with a well-founded relation on states›

locale multithreaded_base_measure = multithreaded_base +
  constrains final :: "'x  bool"
  and r :: "('l,'t,'x,'m,'w,'o) semantics"
  and convert_RA :: "'l released_locks  'o list"
  fixes μ :: "('x × 'm)  ('x × 'm)  bool"
begin

inductive mμt :: "'m  ('l,'t,'x) thread_info  ('l,'t,'x) thread_info  bool"
for m and ts and ts'
where
  mμtI:
  "ln.  finite (dom ts); ts t = (x, ln); ts' t = (x', ln'); μ (x, m) (x', m); t'. t'  t  ts t' = ts' t' 
   mμt m ts ts'"

definition  :: "('l,'t,'x,'m,'w) state  ('l,'t,'x,'m,'w) state  bool"
where " s s'  shr s = shr s'  mμt (shr s) (thr s) (thr s')"

lemma mμt_thr_dom_eq: "mμt m ts ts'  dom ts = dom ts'"
apply(erule mμt.cases)
apply(rule equalityI)
 apply(rule subsetI)
 apply(case_tac "xa = t")
  apply(auto)[2]
apply(rule subsetI)
apply(case_tac "xa = t")
apply auto
done

lemma mμ_finite_thrD:
  assumes "mμt m ts ts'"
  shows "finite (dom ts)" "finite (dom ts')"
using assms
by(simp_all add: mμt_thr_dom_eq[symmetric])(auto elim: mμt.cases)

end

locale multithreaded_base_measure_wf = multithreaded_base_measure +
  constrains final :: "'x  bool"
  and r :: "('l,'t,'x,'m,'w,'o) semantics"
  and convert_RA :: "'l released_locks  'o list"
  and μ :: "('x × 'm)  ('x × 'm)  bool"
  assumes wf_μ: "wfP μ"
begin

lemma wf_mμt: "wfP (mμt m)"
unfolding wfP_eq_minimal
proof(intro strip)
  fix Q :: "('l,'t,'x) thread_info set" and ts
  assume "ts  Q"
  show "zQ. y. mμt m y z  y  Q"
  proof(cases "finite (dom ts)")
    case False
    hence "y. mμt m y ts  y  Q" by(auto dest: mμ_finite_thrD)
    thus ?thesis using ts  Q by blast
  next
    case True
    thus ?thesis using ts  Q
    proof(induct A"dom ts" arbitrary: ts Q rule: finite_induct)
      case empty
      hence "dom ts = {}" by simp
      with ts  Q show ?case by(auto elim: mμt.cases)
    next
      case (insert t A)
      note IH = ts Q. A = dom ts; ts  Q  zQ. y. mμt m y z  y  Q
      define Q' where "Q' = {ts. ts t = None  (xln. ts(t  xln)  Q)}"
      let ?ts' = "ts(t := None)"
      from ‹insert t A = dom ts t  A have "A = dom ?ts'" by auto
      moreover from ‹insert t A = dom ts obtain xln where "ts t = xln" by(cases "ts t") auto
      hence "ts(t  xln) = ts" by(auto simp add: fun_eq_iff)
      with ts  Q have "ts(t  xln)  Q" by(auto)
      hence "?ts'  Q'" unfolding Q'_def by(auto simp del: split_paired_Ex)
      ultimately have "zQ'. y. mμt m y z  y  Q'" by(rule IH)
      then obtain ts' where "ts'  Q'" 
        and min: "ts''. mμt m ts'' ts'  ts''  Q'" by blast
      from ts'  Q' obtain x' ln' where "ts' t = None" "ts'(t  (x', ln'))  Q"
        unfolding Q'_def by auto
      define Q'' where "Q'' = {(x, m)|x. ln. ts'(t  (x, ln))  Q}"
      from ts'(t  (x', ln'))  Q have "(x', m)  Q''" unfolding Q''_def by blast
      hence "xm''Q''. xm'''. μ xm''' xm''  xm'''  Q''" by(rule wf_μ[unfolded wfP_eq_minimal, rule_format])
      then obtain xm'' where "xm''  Q''" and min': "xm'''. μ xm''' xm''  xm'''  Q''" by blast
      from xm''  Q'' obtain x'' ln'' where "xm'' = (x'', m)" "ts'(t  (x'', ln''))  Q" unfolding Q''_def by blast
      moreover {
        fix ts''
        assume "mμt m ts'' (ts'(t  (x'', ln'')))"
        then obtain T X'' LN'' X' LN'
          where "finite (dom ts'')" "ts'' T = (X'', LN'')" 
          and "(ts'(t  (x'', ln''))) T = (X', LN')" "μ (X'', m) (X', m)"
          and eq: "t'. t'  T  ts'' t' = (ts'(t  (x'', ln''))) t'" by(cases) blast
        have "ts''  Q"
        proof(cases "T = t")
          case True
          from True (ts'(t  (x'', ln''))) T = (X', LN') have "X' = x''" by simp
          with μ (X'', m) (X', m) have "(X'', m)  Q''" by(auto dest: min'[unfolded xm'' = (x'', m)])
          hence "ln. ts'(t  (X'', ln))  Q" by(simp add: Q''_def)
          moreover from ts' t = None› eq True
          have "ts''(t := None) = ts'" by(auto simp add: fun_eq_iff)
          with ts'' T = (X'', LN'') True
          have ts'': "ts'' = ts'(t  (X'', LN''))" by(auto intro!: ext)
          ultimately show ?thesis by blast
        next
          case False
          from ‹finite (dom ts'') have "finite (dom (ts''(t := None)))" by simp
          moreover from ts'' T = (X'', LN'') False
          have "(ts''(t := None)) T = (X'', LN'')" by simp
          moreover from (ts'(t  (x'', ln''))) T = (X', LN') False
          have "ts' T = (X', LN')" by simp
          ultimately have "mμt m (ts''(t := None)) ts'" using μ (X'', m) (X', m)
          proof(rule mμtI)
            fix t'
            assume "t'  T"
            with eq[OF False[symmetric]] eq[OF this] ts' t = None›
            show "(ts''(t := None)) t' = ts' t'" by auto
          qed
          hence "ts''(t := None)  Q'" by(rule min)
          thus ?thesis
          proof(rule contrapos_nn)
            assume "ts''  Q"
            from eq[OF False[symmetric]] have "ts'' t = (x'', ln'')" by simp
            hence ts'': "ts''(t  (x'', ln'')) = ts''" by(auto simp add: fun_eq_iff)
            from ts''  Q have "ts''(t  (x'', ln''))  Q" unfolding ts'' .
            thus "ts''(t := None)  Q'" unfolding Q'_def by auto
          qed
        qed
      }
      ultimately show ?case by blast
    qed
  qed
qed

lemma wf_mμ: "wfP mμ"
proof -
  have "wf (inv_image (same_fst (λm. True) (λm. {(ts, ts'). mμt m ts ts'})) (λs. (shr s, thr s)))"
    by(rule wf_inv_image)(rule wf_same_fst, rule wf_mμt[unfolded wfP_def])
  also have "inv_image (same_fst (λm. True) (λm. {(ts, ts'). mμt m ts ts'})) (λs. (shr s, thr s)) = {(s, s').s s'}"
    by(auto simp add: mμ_def same_fst_def)
  finally show ?thesis by(simp add: wfP_def)
qed

end

end

Theory Bisimulation

(*  Title:      JinjaThreads/Framework/Bisimulation.thy
    Author:     Andreas Lochbihler
*)

section ‹Various notions of bisimulation›

theory Bisimulation
imports
  LTS
begin

type_synonym ('a, 'b) bisim = "'a  'b  bool"

subsection ‹Strong bisimulation›

locale bisimulation_base = r1: trsys trsys1 + r2: trsys trsys2
  for trsys1 :: "('s1, 'tl1) trsys" ("_/ -1-_/ _" [50,0,50] 60)
  and trsys2 :: "('s2, 'tl2) trsys" ("_/ -2-_/ _" [50,0,50] 60) +
  fixes bisim :: "('s1, 's2) bisim" ("_/  _" [50, 50] 60)
  and tlsim :: "('tl1, 'tl2) bisim" ("_/  _" [50, 50] 60)
begin

notation
  r1.Trsys ("_/ -1-_→*/ _" [50,0,50] 60) and
  r2.Trsys ("_/ -2-_→*/ _" [50,0,50] 60)

notation
  r1.inf_step ("_ -1-_→* " [50, 0] 80) and
  r2.inf_step ("_ -2-_→* " [50, 0] 80)

notation
  r1.inf_step_table ("_ -1-_→*t " [50, 0] 80) and
  r2.inf_step_table ("_ -2-_→*t " [50, 0] 80)

abbreviation Tlsim :: "('tl1 list, 'tl2 list) bisim" ("_/ [∼] _" [50, 50] 60)
where "Tlsim tl1 tl2  list_all2 tlsim tl1 tl2"

abbreviation Tlsiml :: "('tl1 llist, 'tl2 llist) bisim" ("_/ [[∼]] _" [50, 50] 60)
where "Tlsiml tl1 tl2  llist_all2 tlsim tl1 tl2"

end

locale bisimulation = bisimulation_base +
  constrains trsys1 :: "('s1, 'tl1) trsys"
  and trsys2 :: "('s2, 'tl2) trsys"
  and bisim :: "('s1, 's2) bisim"
  and tlsim :: "('tl1, 'tl2) bisim"
  assumes simulation1: " s1  s2; s1 -1-tl1 s1'   s2' tl2. s2 -2-tl2 s2'  s1'  s2'  tl1  tl2"
  and simulation2: " s1  s2; s2 -2-tl2 s2'   s1' tl1. s1 -1-tl1 s1'  s1'  s2'  tl1  tl2"
begin

lemma bisimulation_flip:
  "bisimulation trsys2 trsys1 (flip bisim) (flip tlsim)"
by(unfold_locales)(unfold flip_simps,(blast intro: simulation1 simulation2)+)

end

lemma bisimulation_flip_simps [flip_simps]:
  "bisimulation trsys2 trsys1 (flip bisim) (flip tlsim) = bisimulation trsys1 trsys2 bisim tlsim"
by(auto dest: bisimulation.bisimulation_flip simp only: flip_flip)

context bisimulation begin

lemma simulation1_rtrancl:
  "s1 -1-tls1→* s1'; s1  s2
   s2' tls2. s2 -2-tls2→* s2'  s1'  s2'  tls1 [∼] tls2"
proof(induct rule: rtrancl3p.induct)
  case rtrancl3p_refl thus ?case by(auto intro: rtrancl3p.rtrancl3p_refl)
next
  case (rtrancl3p_step s1 tls1 s1' tl1 s1'')
  from s1  s2  s2' tls2. s2 -2-tls2→* s2'  s1'  s2'  tls1 [∼] tls2 s1  s2
  obtain s2' tls2 where "s2 -2-tls2→* s2'" "s1'  s2'" "tls1 [∼] tls2" by blast
  moreover from s1' -1-tl1 s1'' s1'  s2'
  obtain s2'' tl2 where "s2' -2-tl2 s2''" "s1''  s2''" "tl1  tl2" by(auto dest: simulation1)
  ultimately have "s2 -2-tls2 @ [tl2]→* s2''" "tls1 @ [tl1] [∼] tls2 @ [tl2]"
    by(auto intro: rtrancl3p.rtrancl3p_step list_all2_appendI)
  with s1''  s2'' show ?case by(blast)
qed

lemma simulation2_rtrancl:
  "s2 -2-tls2→* s2'; s1  s2
   s1' tls1. s1 -1-tls1→* s1'  s1'  s2'  tls1 [∼] tls2"
using bisimulation.simulation1_rtrancl[OF bisimulation_flip]
unfolding flip_simps .

lemma simulation1_inf_step:
  assumes red1: "s1 -1-tls1→* " and bisim: "s1  s2"
  shows "tls2. s2 -2-tls2→*   tls1 [[∼]] tls2"
proof -
  from r1.inf_step_imp_inf_step_table[OF red1]
  obtain stls1 where red1': "s1 -1-stls1→*t " 
    and tls1: "tls1 = lmap (fst  snd) stls1" by blast
  define tl1_to_tl2 where "tl1_to_tl2 s2 stls1 = unfold_llist
     (λ(s2, stls1). lnull stls1)
     (λ(s2, stls1). let (s1, tl1, s1') = lhd stls1;
                        (tl2, s2') = SOME (tl2, s2'). trsys2 s2 tl2 s2'  s1'  s2'  tl1  tl2
                    in (s2, tl2, s2'))
     (λ(s2, stls1). let (s1, tl1, s1') = lhd stls1;
                        (tl2, s2') = SOME (tl2, s2'). trsys2 s2 tl2 s2'  s1'  s2'  tl1  tl2
                    in (s2', ltl stls1))
     (s2, stls1)"
    for s2 :: 's2 and stls1 :: "('s1 × 'tl1 × 's1) llist"

  have tl1_to_tl2_simps [simp]:
    "s2 stls1. lnull (tl1_to_tl2 s2 stls1)  lnull stls1"
    "s2 stls1. ¬ lnull stls1  lhd (tl1_to_tl2 s2 stls1) =
    (let (s1, tl1, s1') = lhd stls1;
         (tl2, s2') = SOME (tl2, s2'). trsys2 s2 tl2 s2'  s1'  s2'  tl1  tl2
     in (s2, tl2, s2'))"
    "s2 stls1. ¬ lnull stls1  ltl (tl1_to_tl2 s2 stls1) =
    (let (s1, tl1, s1') = lhd stls1;
         (tl2, s2') = SOME (tl2, s2'). trsys2 s2 tl2 s2'  s1'  s2'  tl1  tl2
     in tl1_to_tl2 s2' (ltl stls1))"
    "s2. tl1_to_tl2 s2 LNil = LNil"
    "s2 s1 tl1 s1' stls1'. tl1_to_tl2 s2 (LCons (s1, tl1, s1') stls1') =
        LCons (s2, SOME (tl2, s2'). trsys2 s2 tl2 s2'  s1'  s2'  tl1  tl2) 
              (tl1_to_tl2 (snd (SOME (tl2, s2'). trsys2 s2 tl2 s2'  s1'  s2'  tl1  tl2)) stls1')"
    by(simp_all add: tl1_to_tl2_def split_beta)

  have [simp]: "llength (tl1_to_tl2 s2 stls1) = llength stls1"
    by(coinduction arbitrary: s2 stls1 rule: enat_coinduct)(auto simp add: epred_llength split_beta)

  from red1' bisim have "s2 -2-tl1_to_tl2 s2 stls1→*t "
  proof(coinduction arbitrary: s2 s1 stls1)
    case (inf_step_table s2 s1 stls1)
    note red1' = s1 -1-stls1→*t  and bisim = s1  s2
    from red1' show ?case
    proof(cases)
      case (inf_step_tableI s1' stls1' tl1)
      hence stls1: "stls1 = LCons (s1, tl1, s1') stls1'"
        and r: "s1 -1-tl1 s1'" and reds1: "s1' -1-stls1'→*t " by simp_all
      let ?tl2s2' = "SOME (tl2, s2'). s2 -2-tl2 s2'  s1'  s2'  tl1  tl2"
      let ?tl2 = "fst ?tl2s2'" let ?s2' = "snd ?tl2s2'"
      from simulation1[OF bisim r] obtain s2' tl2
        where "s2 -2-tl2 s2'" "s1'  s2'" "tl1  tl2" by blast
      hence "(λ(tl2, s2'). s2 -2-tl2 s2'  s1'  s2'  tl1  tl2) (tl2, s2')" by simp
      hence "(λ(tl2, s2'). s2 -2-tl2 s2'  s1'  s2'  tl1  tl2) ?tl2s2'" by(rule someI)
      hence "s2 -2-?tl2 ?s2'" "s1'  ?s2'" "tl1  ?tl2" by(simp_all add: split_beta)
      then show ?thesis using reds1 stls1 by(fastforce intro: prod_eqI)
    qed
  qed
  hence "s2 -2-lmap (fst  snd) (tl1_to_tl2 s2 stls1)→* "
    by(rule r2.inf_step_table_imp_inf_step)
  moreover have "tls1 [[∼]] lmap (fst  snd) (tl1_to_tl2 s2 stls1)"
  proof(rule llist_all2_all_lnthI)
    show "llength tls1 = llength (lmap (fst  snd) (tl1_to_tl2 s2 stls1))"
      using tls1 by simp
  next
    fix n
    assume "enat n < llength tls1"
    thus "lnth tls1 n  lnth (lmap (fst  snd) (tl1_to_tl2 s2 stls1)) n"
      using red1' bisim unfolding tls1
    proof(induct n arbitrary: s1 s2 stls1 rule: nat_less_induct)
      case (1 n)
      hence IH: "m s1 s2 stls1.  m < n; enat m < llength (lmap (fst  snd) stls1);
                                   s1 -1-stls1→*t ; s1  s2 
                  lnth (lmap (fst  snd) stls1) m  lnth (lmap (fst  snd) (tl1_to_tl2 s2 stls1)) m"
        by blast
      from s1 -1-stls1→*t  show ?case
      proof cases
        case (inf_step_tableI s1' stls1' tl1)
        hence  stls1: "stls1 = LCons (s1, tl1, s1') stls1'"
          and r: "s1 -1-tl1 s1'" and reds: "s1' -1-stls1'→*t " by simp_all
        let ?tl2s2' = "SOME (tl2, s2').  s2 -2-tl2 s2'  s1'  s2'  tl1  tl2"
        let ?tl2 = "fst ?tl2s2'" let ?s2' = "snd ?tl2s2'"
        from simulation1[OF s1  s2 r] obtain s2' tl2
          where "s2 -2-tl2 s2'  s1'  s2'  tl1  tl2" by blast
        hence "(λ(tl2, s2'). s2 -2-tl2 s2'  s1'  s2'  tl1  tl2) (tl2, s2')" by simp
        hence "(λ(tl2, s2'). s2 -2-tl2 s2'  s1'  s2'  tl1  tl2) ?tl2s2'" by(rule someI)
        hence bisim': "s1'  ?s2'" and tlsim: "tl1  ?tl2" by(simp_all add: split_beta)
        show ?thesis
        proof(cases n)
          case 0
          with stls1 tlsim show ?thesis by simp
        next
          case (Suc m)
          hence "m < n" by simp
          moreover have "enat m < llength (lmap (fst  snd) stls1')"
            using stls1 ‹enat n < llength (lmap (fst  snd) stls1) Suc by(simp add: Suc_ile_eq)
          ultimately have "lnth (lmap (fst  snd) stls1') m  lnth (lmap (fst  snd) (tl1_to_tl2 ?s2' stls1')) m"
            using reds bisim' by(rule IH)
          with Suc stls1 show ?thesis by(simp del: o_apply)
        qed
      qed
    qed
  qed
  ultimately show ?thesis by blast
qed

lemma simulation2_inf_step:
  " s2 -2-tls2→* ; s1  s2   tls1. s1 -1-tls1→*   tls1 [[∼]] tls2"
using bisimulation.simulation1_inf_step[OF bisimulation_flip]
unfolding flip_simps .

end

locale bisimulation_final_base =
  bisimulation_base + 
  constrains trsys1 :: "('s1, 'tl1) trsys"
  and trsys2 :: "('s2, 'tl2) trsys"
  and bisim :: "('s1, 's2) bisim"
  and tlsim :: "('tl1, 'tl2) bisim"
  fixes final1 :: "'s1  bool"
  and final2 :: "'s2  bool"

locale bisimulation_final = bisimulation_final_base + bisimulation +
  constrains trsys1 :: "('s1, 'tl1) trsys"
  and trsys2 :: "('s2, 'tl2) trsys"
  and bisim :: "('s1, 's2) bisim"
  and tlsim :: "('tl1, 'tl2) bisim"
  and final1 :: "'s1  bool"
  and final2 :: "'s2  bool"
  assumes bisim_final: "s1  s2  final1 s1  final2 s2"

begin

lemma bisimulation_final_flip:
  "bisimulation_final trsys2 trsys1 (flip bisim) (flip tlsim) final2 final1"
apply(intro_locales)
apply(rule bisimulation_flip)
apply(unfold_locales)
by(unfold flip_simps, rule bisim_final[symmetric])

end

lemma bisimulation_final_flip_simps [flip_simps]:
  "bisimulation_final trsys2 trsys1 (flip bisim) (flip tlsim) final2 final1 =
   bisimulation_final trsys1 trsys2 bisim tlsim final1 final2"
by(auto dest: bisimulation_final.bisimulation_final_flip simp only: flip_flip)

context bisimulation_final begin

lemma final_simulation1:
  " s1  s2; s1 -1-tls1→* s1'; final1 s1' 
   s2' tls2. s2 -2-tls2→* s2'  s1'  s2'  final2 s2'  tls1 [∼] tls2"
by(auto dest: bisim_final dest!: simulation1_rtrancl)

lemma final_simulation2:
  " s1  s2; s2 -2-tls2→* s2'; final2 s2' 
   s1' tls1. s1 -1-tls1→* s1'  s1'  s2'  final1 s1'  tls1 [∼] tls2"
by(auto dest: bisim_final dest!: simulation2_rtrancl)

end

subsection ‹Delay bisimulation›

locale delay_bisimulation_base =
  bisimulation_base +
  trsys1?: τtrsys trsys1 τmove1 +
  trsys2?: τtrsys trsys2 τmove2 
  for τmove1 τmove2 +
  constrains trsys1 :: "('s1, 'tl1) trsys"
  and trsys2 :: "('s2, 'tl2) trsys"
  and bisim :: "('s1, 's2) bisim"
  and tlsim :: "('tl1, 'tl2) bisim"
  and τmove1 :: "('s1, 'tl1) trsys"
  and τmove2 :: "('s2, 'tl2) trsys"
begin

notation
  trsys1.silent_move ("_/ -τ1→ _" [50, 50] 60) and
  trsys2.silent_move ("_/ -τ2→ _" [50, 50] 60)

notation
  trsys1.silent_moves ("_/ -τ1→* _" [50, 50] 60) and
  trsys2.silent_moves ("_/ -τ2→* _" [50, 50] 60)

notation
  trsys1.silent_movet ("_/ -τ1→+ _" [50, 50] 60) and
  trsys2.silent_movet ("_/ -τ2→+ _" [50, 50] 60)

notation
  trsys1.τrtrancl3p ("_ -τ1-_→* _" [50, 0, 50] 60) and
  trsys2.τrtrancl3p ("_ -τ2-_→* _" [50, 0, 50] 60)

notation
  trsys1.τinf_step ("_ -τ1-_→* " [50, 0] 80) and
  trsys2.τinf_step ("_ -τ2-_→* " [50, 0] 80)

notation
  trsys1.τdiverge ("_ -τ1→ " [50] 80) and
  trsys2.τdiverge ("_ -τ2→ " [50] 80)

notation
  trsys1.τinf_step_table ("_ -τ1-_→*t " [50, 0] 80) and
  trsys2.τinf_step_table ("_ -τ2-_→*t " [50, 0] 80)

notation
  trsys1.τRuns ("_ ⇓1 _" [50, 50] 51) and
  trsys2.τRuns ("_ ⇓2 _" [50, 50] 51)

lemma simulation_silent1I':
  assumes "s2'. (if μ1 s1' s1 then trsys2.silent_moves else trsys2.silent_movet) s2 s2'  s1'  s2'"
  shows "s1'  s2  μ1^++ s1' s1  (s2'. s2 -τ2→+ s2'  s1'  s2')"
proof -
  from assms obtain s2' where red: "(if μ1 s1' s1 then trsys2.silent_moves else trsys2.silent_movet) s2 s2'" 
    and bisim: "s1'  s2'" by blast
  show ?thesis
  proof(cases "μ1 s1' s1")
    case True
    with red have "s2 -τ2→* s2'" by simp
    thus ?thesis using bisim True by cases(blast intro: rtranclp_into_tranclp1)+
  next
    case False
    with red bisim show ?thesis by auto
  qed
qed

lemma simulation_silent2I':
  assumes "s1'. (if μ2 s2' s2 then trsys1.silent_moves else trsys1.silent_movet) s1 s1'  s1'  s2'"
  shows "s1  s2'  μ2^++ s2' s2  (s1'. s1 -τ1→+ s1'  s1'  s2')"
using assms
by(rule delay_bisimulation_base.simulation_silent1I')

end

locale delay_bisimulation_obs = delay_bisimulation_base _ _ _ _ τmove1 τmove2
  for τmove1 :: "'s1  'tl1  's1  bool"
  and τmove2 :: "'s2  'tl2  's2  bool" +
  assumes simulation1:
  " s1  s2; s1 -1-tl1 s1'; ¬ τmove1 s1 tl1 s1' 
   s2' s2'' tl2. s2 -τ2→* s2'  s2' -2-tl2 s2''  ¬ τmove2 s2' tl2 s2''  s1'  s2''  tl1  tl2"
  and simulation2:
  " s1  s2; s2 -2-tl2 s2'; ¬ τmove2 s2 tl2 s2' 
   s1' s1'' tl1. s1 -τ1→* s1'  s1' -1-tl1 s1''  ¬ τmove1 s1' tl1 s1''  s1''  s2'  tl1  tl2"
begin

lemma delay_bisimulation_obs_flip: "delay_bisimulation_obs trsys2 trsys1 (flip bisim) (flip tlsim) τmove2 τmove1"
apply(unfold_locales)
apply(unfold flip_simps)
by(blast intro: simulation1 simulation2)+

end

lemma delay_bisimulation_obs_flip_simps [flip_simps]:
  "delay_bisimulation_obs trsys2 trsys1 (flip bisim) (flip tlsim) τmove2 τmove1 =
   delay_bisimulation_obs trsys1 trsys2 bisim tlsim τmove1 τmove2"
by(auto dest: delay_bisimulation_obs.delay_bisimulation_obs_flip simp only: flip_flip)

locale delay_bisimulation_diverge = delay_bisimulation_obs _ _ _ _ τmove1 τmove2
  for τmove1 :: "'s1  'tl1  's1  bool"
  and τmove2 :: "'s2  'tl2  's2  bool" +
  assumes simulation_silent1:
  " s1  s2; s1 -τ1→ s1'   s2'. s2 -τ2→* s2'  s1'  s2'"
  and simulation_silent2:
  " s1  s2; s2 -τ2→ s2'   s1'. s1 -τ1→* s1'  s1'  s2'"
  and τdiverge_bisim_inv: "s1  s2  s1 -τ1→   s2 -τ2→ "
begin

lemma delay_bisimulation_diverge_flip: "delay_bisimulation_diverge trsys2 trsys1 (flip bisim) (flip tlsim) τmove2 τmove1"
apply(rule delay_bisimulation_diverge.intro)
 apply(rule delay_bisimulation_obs_flip)
apply(unfold_locales)
apply(unfold flip_simps)
by(blast intro: simulation_silent1 simulation_silent2 τdiverge_bisim_inv[symmetric] del: iffI)+

end


lemma delay_bisimulation_diverge_flip_simps [flip_simps]:
  "delay_bisimulation_diverge trsys2 trsys1 (flip bisim) (flip tlsim) τmove2 τmove1 =
   delay_bisimulation_diverge trsys1 trsys2 bisim tlsim τmove1 τmove2"
by(auto dest: delay_bisimulation_diverge.delay_bisimulation_diverge_flip simp only: flip_flip)

context delay_bisimulation_diverge begin

lemma simulation_silents1:
  assumes bisim: "s1  s2" and moves: "s1 -τ1→* s1'"
  shows "s2'. s2 -τ2→* s2'  s1'  s2'"
using moves bisim
proof induct
  case base thus ?case by(blast)
next
  case (step s1' s1'')
  from s1  s2  s2'. s2 -τ2→* s2'  s1'  s2' s1  s2
  obtain s2' where "s2 -τ2→* s2'" "s1'  s2'" by blast
  from simulation_silent1[OF s1'  s2' s1' -τ1→ s1'']
  obtain s2'' where "s2' -τ2→* s2''" "s1''  s2''" by blast
  from s2 -τ2→* s2' s2' -τ2→* s2'' have "s2 -τ2→* s2''" by(rule rtranclp_trans)
  with s1''  s2'' show ?case by blast
qed

lemma simulation_silents2:
  " s1  s2; s2 -τ2→* s2'   s1'. s1 -τ1→* s1'  s1'  s2'"
using delay_bisimulation_diverge.simulation_silents1[OF delay_bisimulation_diverge_flip]
unfolding flip_simps .

lemma simulation1_τrtrancl3p:
  " s1 -τ1-tls1→* s1'; s1  s2 
   tls2 s2'. s2 -τ2-tls2→* s2'  s1'  s2'  tls1 [∼] tls2"
proof(induct arbitrary: s2 rule: trsys1.τrtrancl3p.induct)
  case (τrtrancl3p_refl s)
  thus ?case by(auto intro: τtrsys.τrtrancl3p.intros)
next
  case (τrtrancl3p_step s1 s1' tls1 s1'' tl1)
  from simulation1[OF s1  s2 s1 -1-tl1 s1' ¬ τmove1 s1 tl1 s1']
  obtain s2' s2'' tl2 where τred: "s2 -τ2→* s2'"
    and red: "s2' -2-tl2 s2''" and: "¬ τmove2 s2' tl2 s2''"
    and bisim': "s1'  s2''" and tlsim: "tl1  tl2" by blast
  from bisim' s1'  s2''  tls2 s2'. s2'' -τ2-tls2→* s2'  s1''  s2'  tls1 [∼] tls2
  obtain tls2 s2''' where IH: "s2'' -τ2-tls2→* s2'''" "s1''  s2'''" "tls1 [∼] tls2" by blast
  from τred have "s2 -τ2-[]→* s2'" by(rule trsys2.silent_moves_into_τrtrancl3p)
  also from red nτ IH(1) have "s2' -τ2-tl2 # tls2→* s2'''" by(rule τrtrancl3p.τrtrancl3p_step)
  finally show ?case using IH tlsim by fastforce
next
  case (τrtrancl3p_τstep s1 s1' tls1 s1'' tl1)
  from s1 -1-tl1 s1' τmove1 s1 tl1 s1' have "s1 -τ1→ s1'" .. 
  from simulation_silent1[OF s1  s2 this]
  obtain s2' where τred: "s2 -τ2→* s2'" and bisim': "s1'  s2'" by blast
  from τred have "s2 -τ2-[]→* s2'" by(rule trsys2.silent_moves_into_τrtrancl3p)
  also from bisim' s1'  s2'  tls2 s2''. s2' -τ2-tls2→* s2''  s1''  s2''  tls1 [∼] tls2
  obtain tls2 s2'' where IH: "s2' -τ2-tls2→* s2''" "s1''  s2''" "tls1 [∼] tls2" by blast
  note s2' -τ2-tls2→* s2''
  finally show ?case using IH by auto
qed

lemma simulation2_τrtrancl3p:
  " s2 -τ2-tls2→* s2'; s1  s2 
   tls1 s1'. s1 -τ1-tls1→* s1'  s1'  s2'  tls1 [∼] tls2"
using delay_bisimulation_diverge.simulation1_τrtrancl3p[OF delay_bisimulation_diverge_flip]
unfolding flip_simps .

lemma simulation1_τinf_step:
  assumes τinf1: "s1 -τ1-tls1→* " and bisim: "s1  s2"
  shows "tls2. s2 -τ2-tls2→*   tls1 [[∼]] tls2"
proof -
  from trsys1.τinf_step_imp_τinf_step_table[OF τinf1]
  obtain sstls1 where τinf1': "s1 -τ1-sstls1→*t " 
    and tls1: "tls1 = lmap (fst  snd  snd) sstls1" by blast
  define tl1_to_tl2 where "tl1_to_tl2 s2 sstls1 = unfold_llist
     (λ(s2, sstls1). lnull sstls1)
     (λ(s2, sstls1).
        let (s1, s1', tl1, s1'') = lhd sstls1;
            (s2', tl2, s2'') = SOME (s2', tl2, s2''). s2 -τ2→* s2'  trsys2 s2' tl2 s2'' 
                                     ¬ τmove2 s2' tl2 s2''   s1''  s2''  tl1  tl2
        in (s2, s2', tl2, s2''))
     (λ(s2, sstls1). 
        let (s1, s1', tl1, s1'') = lhd sstls1;
            (s2', tl2, s2'') = SOME (s2', tl2, s2''). s2 -τ2→* s2'  trsys2 s2' tl2 s2'' 
                                     ¬ τmove2 s2' tl2 s2''   s1''  s2''  tl1  tl2
        in (s2'', ltl sstls1))
     (s2, sstls1)"
    for s2 :: 's2 and sstls1 :: "('s1 × 's1 × 'tl1 × 's1) llist"
  have [simp]:
    "s2 sstls1. lnull (tl1_to_tl2 s2 sstls1)  lnull sstls1"
    "s2 sstls1. ¬ lnull sstls1  lhd (tl1_to_tl2 s2 sstls1) =
        (let (s1, s1', tl1, s1'') = lhd sstls1;
            (s2', tl2, s2'') = SOME (s2', tl2, s2''). s2 -τ2→* s2'  trsys2 s2' tl2 s2'' 
                                     ¬ τmove2 s2' tl2 s2''   s1''  s2''  tl1  tl2
        in (s2, s2', tl2, s2''))"
    "s2 sstls1. ¬ lnull sstls1  ltl (tl1_to_tl2 s2 sstls1) =
        (let (s1, s1', tl1, s1'') = lhd sstls1;
            (s2', tl2, s2'') = SOME (s2', tl2, s2''). s2 -τ2→* s2'  trsys2 s2' tl2 s2'' 
                                     ¬ τmove2 s2' tl2 s2''   s1''  s2''  tl1  tl2
        in tl1_to_tl2 s2'' (ltl sstls1))"
    "s2. tl1_to_tl2 s2 LNil = LNil"
    "s2 s1 s1' tl1 s1'' stls1'. tl1_to_tl2 s2 (LCons (s1, s1', tl1, s1'') stls1') =
        LCons (s2, SOME (s2', tl2, s2''). s2 -τ2→* s2'  trsys2 s2' tl2 s2''  
                                          ¬ τmove2 s2' tl2 s2''  s1''  s2''  tl1  tl2) 
              (tl1_to_tl2 (snd (snd (SOME (s2', tl2, s2''). s2 -τ2→* s2'  trsys2 s2' tl2 s2'' 
                                                            ¬ τmove2 s2' tl2 s2''  s1''  s2''  tl1  tl2)))
                           stls1')"
    by(simp_all add: tl1_to_tl2_def split_beta)

  have [simp]: "llength (tl1_to_tl2 s2 sstls1) = llength sstls1"
    by(coinduction arbitrary: s2 sstls1 rule: enat_coinduct)(auto simp add: epred_llength split_beta)

  define sstls2 where "sstls2 = tl1_to_tl2 s2 sstls1"
  with τinf1' bisim have "s1 sstls1. s1 -τ1-sstls1→*t   sstls2 = tl1_to_tl2 s2 sstls1  s1  s2" by blast

  from τinf1' bisim have "s2 -τ2-tl1_to_tl2 s2 sstls1→*t "
  proof(coinduction arbitrary: s2 s1 sstls1)
    case (τinf_step_table s2 s1 sstls1)
    note τinf' = s1 -τ1-sstls1→*t  and bisim = s1  s2
    from τinf' show ?case
    proof(cases)
      case (τinf_step_table_Cons s1' s1'' sstls1' tl1)
      hence sstls1: "sstls1 = LCons (s1, s1', tl1, s1'') sstls1'"
        and τs: "s1 -τ1→* s1'" and r: "s1' -1-tl1 s1''" and: "¬ τmove1 s1' tl1 s1''"
        and reds1: "s1'' -τ1-sstls1'→*t " by simp_all
      let ?P = "λ(s2', tl2, s2''). s2 -τ2→* s2'  trsys2 s2' tl2 s2''  ¬ τmove2 s2' tl2 s2''   s1''  s2''  tl1  tl2"
      let ?s2tl2s2' = "Eps ?P"
      let ?s2'' = "snd (snd ?s2tl2s2')"
      from simulation_silents1[OF s1  s2 τs]
      obtain s2' where "s2 -τ2→* s2'" "s1'  s2'" by blast
      from simulation1[OF s1'  s2' r nτ] obtain s2'' s2''' tl2
        where "s2' -τ2→* s2''" 
        and rest: "s2'' -2-tl2 s2'''" "¬ τmove2 s2'' tl2 s2'''" "s1''  s2'''" "tl1  tl2" by blast
      from s2 -τ2→* s2' s2' -τ2→* s2'' have "s2 -τ2→* s2''" by(rule rtranclp_trans)
      with rest have "?P (s2'', tl2, s2''')" by simp
      hence "?P ?s2tl2s2'" by(rule someI)
      then show ?thesis using reds1 sstls1 by fastforce
    next
      case τinf_step_table_Nil
      hence [simp]: "sstls1 = LNil" and "s1 -τ1→ " by simp_all
      from s1 -τ1→  s1  s2 have "s2 -τ2→ " by(simp add: τdiverge_bisim_inv)
      thus ?thesis using sstls2_def by simp
    qed
  qed
  hence "s2 -τ2-lmap (fst  snd  snd) (tl1_to_tl2 s2 sstls1)→* "
    by(rule trsys2.τinf_step_table_into_τinf_step)
  moreover have "tls1 [[∼]] lmap (fst  snd  snd) (tl1_to_tl2 s2 sstls1)"
  proof(rule llist_all2_all_lnthI)
    show "llength tls1 = llength (lmap (fst  snd  snd) (tl1_to_tl2 s2 sstls1))"
      using tls1 by simp
  next
    fix n
    assume "enat n < llength tls1"
    thus "lnth tls1 n  lnth (lmap (fst  snd  snd) (tl1_to_tl2 s2 sstls1)) n"
      using τinf1' bisim unfolding tls1
    proof(induct n arbitrary: s1 s2 sstls1 rule: less_induct)
      case (less n)
      note IH = m s1 s2 sstls1.  m < n; enat m < llength (lmap (fst  snd  snd) sstls1);
                                   s1 -τ1-sstls1→*t ; s1  s2 
                  lnth (lmap (fst  snd  snd) sstls1) m  lnth (lmap (fst  snd  snd) (tl1_to_tl2 s2 sstls1)) m
      from s1 -τ1-sstls1→*t  show ?case
      proof cases
        case (τinf_step_table_Cons s1' s1'' sstls1' tl1)
        hence sstls1: "sstls1 = LCons (s1, s1', tl1, s1'') sstls1'"
          and τs: "s1 -τ1→* s1'" and r: "s1' -1-tl1 s1''"
          and: "¬ τmove1 s1' tl1 s1''" and reds: "s1'' -τ1-sstls1'→*t " by simp_all
        let ?P = "λ(s2', tl2, s2''). s2 -τ2→* s2'  trsys2 s2' tl2 s2''  ¬ τmove2 s2' tl2 s2''   s1''  s2''  tl1  tl2"
        let ?s2tl2s2' = "Eps ?P" let ?tl2 = "fst (snd ?s2tl2s2')" let ?s2'' = "snd (snd ?s2tl2s2')"
        from simulation_silents1[OF s1  s2 τs] obtain s2'
          where "s2 -τ2→* s2'" "s1'  s2'" by blast
        from simulation1[OF s1'  s2' r nτ] obtain s2'' s2''' tl2
          where "s2' -τ2→* s2''"
          and rest: "s2'' -2-tl2 s2'''" "¬ τmove2 s2'' tl2 s2'''" "s1''  s2'''" "tl1  tl2" by blast
        from s2 -τ2→* s2' s2' -τ2→* s2'' have "s2 -τ2→* s2''" by(rule rtranclp_trans)
        with rest have "?P (s2'', tl2, s2''')" by auto
        hence "?P ?s2tl2s2'" by(rule someI)
        hence "s1''  ?s2''" "tl1  ?tl2" by(simp_all add: split_beta)
        show ?thesis
        proof(cases n)
          case 0
          with sstls1 tl1  ?tl2 show ?thesis by simp
        next
          case (Suc m)
          hence "m < n" by simp
          moreover have "enat m < llength (lmap (fst  snd  snd) sstls1')"
            using sstls1 ‹enat n < llength (lmap (fst  snd  snd) sstls1) Suc by(simp add: Suc_ile_eq)
          ultimately have "lnth (lmap (fst  snd  snd) sstls1') m  lnth (lmap (fst  snd  snd) (tl1_to_tl2 ?s2'' sstls1')) m"
            using reds s1''  ?s2'' by(rule IH)
          with Suc sstls1 show ?thesis by(simp del: o_apply)
        qed
      next
        case τinf_step_table_Nil
        with ‹enat n < llength (lmap (fst  snd  snd) sstls1) have False by simp
        thus ?thesis ..
      qed
    qed
  qed
  ultimately show ?thesis by blast
qed

lemma simulation2_τinf_step:
  " s2 -τ2-tls2→* ; s1  s2   tls1. s1 -τ1-tls1→*   tls1 [[∼]] tls2"
using delay_bisimulation_diverge.simulation1_τinf_step[OF delay_bisimulation_diverge_flip]
unfolding flip_simps .

lemma no_τmove1_τs_to_no_τmove2:
  assumes "s1  s2"
  and no_τmoves1: "s1'. ¬ s1 -τ1→ s1'"
  shows "s2'. s2 -τ2→* s2'  (s2''. ¬ s2' -τ2→ s2'')  s1  s2'"
proof -
  have "¬ s1 -τ1→ "
  proof
    assume "s1 -τ1→ "
    then obtain s1' where "s1 -τ1→ s1'" by cases
    with no_τmoves1[of s1'] show False by contradiction
  qed
  with s1  s2 have "¬ s2 -τ2→ " by(simp add: τdiverge_bisim_inv)
  from trsys2.not_τdiverge_to_no_τmove[OF this]
  obtain s2' where "s2 -τ2→* s2'" and "s2''. ¬ s2' -τ2→ s2''" by blast
  moreover from simulation_silents2[OF s1  s2 s2 -τ2→* s2']
  obtain s1' where "s1 -τ1→* s1'" and "s1'  s2'" by blast
  from s1 -τ1→* s1' no_τmoves1 have "s1' = s1"
    by(auto elim: converse_rtranclpE)
  ultimately show ?thesis using s1'  s2' by blast
qed

lemma no_τmove2_τs_to_no_τmove1:
  " s1  s2; s2'. ¬ s2 -τ2→ s2'   s1'. s1 -τ1→* s1'  (s1''. ¬ s1' -τ1→ s1'')  s1'  s2"
using delay_bisimulation_diverge.no_τmove1_τs_to_no_τmove2[OF delay_bisimulation_diverge_flip]
unfolding flip_simps .

lemma no_move1_to_no_move2:
  assumes "s1  s2"
  and no_moves1: "tl1 s1'. ¬ s1 -1-tl1 s1'"
  shows "s2'. s2 -τ2→* s2'  (tl2 s2''. ¬ s2' -2-tl2 s2'')  s1  s2'"
proof -
  from no_moves1 have "s1'. ¬ s1 -τ1→ s1'" by(auto)
  from no_τmove1_τs_to_no_τmove2[OF s1  s2 this]
  obtain s2' where "s2 -τ2→* s2'" and "s1  s2'" 
    and no_τmoves2: "s2''. ¬ s2' -τ2→ s2''" by blast
  moreover
  have "tl2 s2''. ¬ s2' -2-tl2 s2''"
  proof
    fix tl2 s2''
    assume "s2' -2-tl2 s2''"
    with no_τmoves2[of s2''] have "¬ τmove2 s2' tl2 s2''" by(auto)
    from simulation2[OF s1  s2' s2' -2-tl2 s2'' this]
    obtain s1' s1'' tl1 where "s1 -τ1→* s1'" and "s1' -1-tl1 s1''" by blast
    with no_moves1 show False by(fastforce elim: converse_rtranclpE)
  qed
  ultimately show ?thesis by blast
qed

lemma no_move2_to_no_move1:
  " s1  s2; tl2 s2'. ¬ s2 -2-tl2 s2' 
   s1'. s1 -τ1→* s1'  (tl1 s1''. ¬ s1' -1-tl1 s1'')  s1'  s2"
using delay_bisimulation_diverge.no_move1_to_no_move2[OF delay_bisimulation_diverge_flip]
unfolding flip_simps .

lemma simulation_τRuns_table1:
  assumes bisim: "s1  s2"
  and run1: "trsys1.τRuns_table s1 stlsss1"
  shows "stlsss2. trsys2.τRuns_table s2 stlsss2  tllist_all2 (λ(tl1, s1'') (tl2, s2''). tl1  tl2  s1''  s2'') (rel_option bisim) stlsss1 stlsss2"
proof(intro exI conjI)
  let ?P = "λ(s2 :: 's2) (stlsss1 :: ('tl1 × 's1, 's1 option) tllist) (tl2, s2'').
    s2'. s2 -τ2→* s2'  s2' -2-tl2 s2''  ¬ τmove2 s2' tl2 s2''  snd (thd stlsss1)  s2''  fst (thd stlsss1)  tl2"
  define tls1_to_tls2 where "tls1_to_tls2 s2 stlsss1 = unfold_tllist
      (λ(s2, stlsss1). is_TNil stlsss1)
      (λ(s2, stlsss1). map_option (λs1'. SOME s2'. s2 -τ2→* s2'  (tl s2''. ¬ s2' -2-tl s2'')  s1'  s2') (terminal stlsss1))
      (λ(s2, stlsss1). let (tl2, s2'') = Eps (?P s2 stlsss1) in (tl2, s2''))
      (λ(s2, stlsss1). let (tl2, s2'') = Eps (?P s2 stlsss1) in (s2'', ttl stlsss1))
      (s2, stlsss1)"
    for s2 stlsss1
  have [simp]:
    "s2 stlsss1. is_TNil (tls1_to_tls2 s2 stlsss1)  is_TNil stlsss1"
    "s2 stlsss1. is_TNil stlsss1  terminal (tls1_to_tls2 s2 stlsss1) = map_option (λs1'. SOME s2'. s2 -τ2→* s2'  (tl s2''. ¬ s2' -2-tl s2'')  s1'  s2') (terminal stlsss1)"
    "s2 stlsss1. ¬ is_TNil stlsss1  thd (tls1_to_tls2 s2 stlsss1) = (let (tl2, s2'') = Eps (?P s2 stlsss1) in (tl2, s2''))"
    "s2 stlsss1. ¬ is_TNil stlsss1  ttl (tls1_to_tls2 s2 stlsss1) = (let (tl2, s2'') = Eps (?P s2 stlsss1) in tls1_to_tls2 s2'' (ttl stlsss1))"
    "s2 os1. tls1_to_tls2 s2 (TNil os1) = 
               TNil (map_option (λs1'. SOME s2'. s2 -τ2→* s2'  (tl s2''. ¬ s2' -2-tl s2'')  s1'  s2') os1)"
    by(simp_all add: tls1_to_tls2_def split_beta)
  have [simp]:
    "s2 s1 s1' tl1 s1'' stlsss1. 
     tls1_to_tls2 s2 (TCons (tl1, s1'') stlsss1) =
     (let (tl2, s2'') = SOME (tl2, s2''). s2'. s2 -τ2→* s2'  s2' -2-tl2 s2''  
                             ¬ τmove2 s2' tl2 s2''  s1''  s2''  tl1  tl2
      in TCons (tl2, s2'') (tls1_to_tls2 s2'' stlsss1))"
    by(rule tllist.expand)(simp_all add: split_beta)

  from bisim run1
  show "trsys2.τRuns_table s2 (tls1_to_tls2 s2 stlsss1)"
  proof(coinduction arbitrary: s2 s1 stlsss1)
    case (τRuns_table s2 s1 stlsss1)
    note bisim = s1  s2
      and run1 = ‹trsys1.τRuns_table s1 stlsss1
    from run1 show ?case
    proof cases
      case (Terminate s1')
      let ?P = "λs2'. s2 -τ2→* s2'  (tl2 s2''. ¬ s2' -2-tl2 s2'')  s1'  s2'"
      from simulation_silents1[OF bisim s1 -τ1→* s1']
      obtain s2' where "s2 -τ2→* s2'" and "s1'  s2'" by blast
      moreover from no_move1_to_no_move2[OF s1'  s2' tl1 s1''. ¬ s1' -1-tl1 s1'']
      obtain s2'' where "s2' -τ2→* s2''" and "s1'  s2''" 
        and "tl2 s2'''. ¬ s2'' -2-tl2 s2'''" by blast
      ultimately have "?P s2''" by(blast intro: rtranclp_trans)
      hence "?P (Eps ?P)" by(rule someI)
      hence ?Terminate using stlsss1 = TNil s1' by simp
      thus ?thesis ..
    next
      case Diverge
      with τdiverge_bisim_inv[OF bisim]
      have ?Diverge by simp
      thus ?thesis by simp
    next
      case (Proceed s1' s1'' stlsss1' tl1)
      let ?P = "λ(tl2, s2''). s2'. s2 -τ2→* s2'  s2' -2-tl2 s2''  ¬ τmove2 s2' tl2 s2''  s1''  s2''  tl1  tl2"
      from simulation_silents1[OF bisim s1 -τ1→* s1']
      obtain s2' where "s2 -τ2→* s2'" and "s1'  s2'" by blast
      moreover from simulation1[OF s1'  s2' s1' -1-tl1 s1'' ¬ τmove1 s1' tl1 s1'']
      obtain s2'' s2''' tl2 where "s2' -τ2→* s2''"
        and "s2'' -2-tl2 s2'''" and "¬ τmove2 s2'' tl2 s2'''"
        and "s1''  s2'''" and "tl1  tl2" by blast
      ultimately have "?P (tl2, s2''')" by(blast intro: rtranclp_trans)
      hence "?P (Eps ?P)" by(rule someI)
      hence ?Proceed 
        using stlsss1 = TCons (tl1, s1'') stlsss1' ‹trsys1.τRuns_table s1'' stlsss1'
        by auto blast
      thus ?thesis by simp
    qed
  qed

  let ?Tlsim = "λ(tl1, s1'') (tl2, s2''). tl1  tl2  s1''  s2''"
  let ?Bisim = "rel_option bisim"
  from run1 bisim
  show "tllist_all2 ?Tlsim ?Bisim stlsss1 (tls1_to_tls2 s2 stlsss1)"
  proof(coinduction arbitrary: s1 s2 stlsss1)
    case (tllist_all2 s1 s2 stlsss1)
    note Runs = ‹trsys1.τRuns_table s1 stlsss1 and bisim = s1  s2
    from Runs show ?case
    proof cases
      case (Terminate s1')
      let ?P = "λs2'. s2 -τ2→* s2'  (tl2 s2''. ¬ s2' -2-tl2 s2'')  s1'  s2'"
      from simulation_silents1[OF bisim s1 -τ1→* s1']
      obtain s2' where "s2 -τ2→* s2'" and "s1'  s2'" by blast
      moreover
      from no_move1_to_no_move2[OF s1'  s2' tl1 s1''. ¬ s1' -1-tl1 s1'']
      obtain s2'' where "s2' -τ2→* s2''" and "s1'  s2''"
        and "tl2 s2'''. ¬ s2'' -2-tl2 s2'''" by blast
      ultimately have "?P s2''" by(blast intro: rtranclp_trans)
      hence "?P (Eps ?P)" by(rule someI)
      thus ?thesis using stlsss1 = TNil s1' bisim by(simp)
    next
      case (Proceed s1' s1'' stlsss1' tl1)
      from simulation_silents1[OF bisim s1 -τ1→* s1']
      obtain s2' where "s2 -τ2→* s2'" and "s1'  s2'" by blast
      moreover from simulation1[OF s1'  s2' s1' -1-tl1 s1'' ¬ τmove1 s1' tl1 s1'']
      obtain s2'' s2''' tl2 where "s2' -τ2→* s2''"
        and "s2'' -2-tl2 s2'''" and "¬ τmove2 s2'' tl2 s2'''"
        and "s1''  s2'''" and "tl1  tl2" by blast
      ultimately have "?P s2 stlsss1 (tl2, s2''')"
        using stlsss1 = TCons (tl1, s1'') stlsss1' by(auto intro: rtranclp_trans)
      hence "?P s2 stlsss1 (Eps (?P s2 stlsss1))" by(rule someI)
      thus ?thesis using stlsss1 = TCons (tl1, s1'') stlsss1' ‹trsys1.τRuns_table s1'' stlsss1' bisim
        by auto blast
    qed simp
  qed
qed

lemma simulation_τRuns_table2:
  assumes "s1  s2"
  and "trsys2.τRuns_table s2 stlsss2"
  shows "stlsss1. trsys1.τRuns_table s1 stlsss1  tllist_all2 (λ(tl1, s1'') (tl2, s2''). tl1  tl2  s1''  s2'') (rel_option bisim) stlsss1 stlsss2"
using delay_bisimulation_diverge.simulation_τRuns_table1[OF delay_bisimulation_diverge_flip, unfolded flip_simps, OF assms]
by(subst tllist_all2_flip[symmetric])(simp only: flip_def split_def)

lemma simulation_τRuns1:
  assumes bisim: "s1  s2"
  and run1: "s1 ⇓1 tls1"
  shows "tls2. s2 ⇓2 tls2  tllist_all2 tlsim (rel_option bisim) tls1 tls2"
proof -
  from trsys1.τRuns_into_τRuns_table[OF run1]
  obtain stlsss1 where tls1: "tls1 = tmap fst id stlsss1"
    and τRuns1: "trsys1.τRuns_table s1 stlsss1" by blast
  from simulation_τRuns_table1[OF bisim τRuns1]
  obtain stlsss2 where τRuns2: "trsys2.τRuns_table s2 stlsss2"
    and tlsim: "tllist_all2 (λ(tl1, s1'') (tl2, s2''). tl1  tl2  s1''  s2'')
                            (rel_option bisim) stlsss1 stlsss2" by blast
  from τRuns2 have "s2 ⇓2 tmap fst id stlsss2"
    by(rule τRuns_table_into_τRuns)
  moreover have "tllist_all2 tlsim (rel_option bisim) tls1 (tmap fst id stlsss2)"
    using tlsim unfolding tls1
    by(fastforce simp add: tllist_all2_tmap1 tllist_all2_tmap2 elim: tllist_all2_mono rel_option_mono)
  ultimately show ?thesis by blast
qed

lemma simulation_τRuns2:
  " s1  s2; s2 ⇓2 tls2 
   tls1. s1 ⇓1 tls1  tllist_all2 tlsim (rel_option bisim) tls1 tls2"
using delay_bisimulation_diverge.simulation_τRuns1[OF delay_bisimulation_diverge_flip]
unfolding flip_simps .

end

locale delay_bisimulation_final_base =
  delay_bisimulation_base _ _ _ _ τmove1 τmove2 +
  bisimulation_final_base _ _ _ _ final1 final2 
  for τmove1 :: "('s1, 'tl1) trsys"
  and τmove2 :: "('s2, 'tl2) trsys"
  and final1 :: "'s1  bool"
  and final2 :: "'s2  bool" +
  assumes final1_simulation: " s1  s2; final1 s1   s2'. s2 -τ2→* s2'  s1  s2'  final2 s2'"
  and final2_simulation: " s1  s2; final2 s2   s1'. s1 -τ1→* s1'  s1'  s2  final1 s1'"
begin

lemma delay_bisimulation_final_base_flip:
  "delay_bisimulation_final_base trsys2 trsys1 (flip bisim) τmove2 τmove1 final2 final1"
apply(unfold_locales)
apply(unfold flip_simps)
by(blast intro: final1_simulation final2_simulation)+

end

lemma delay_bisimulation_final_base_flip_simps [flip_simps]:
  "delay_bisimulation_final_base trsys2 trsys1 (flip bisim) τmove2 τmove1 final2 final1 =
  delay_bisimulation_final_base trsys1 trsys2 bisim τmove1 τmove2 final1 final2"
by(auto dest: delay_bisimulation_final_base.delay_bisimulation_final_base_flip simp only: flip_flip)

context delay_bisimulation_final_base begin

lemma τRuns_terminate_final1:
  assumes "s1 ⇓1 tls1"
  and "s2 ⇓2 tls2"
  and "tllist_all2 tlsim (rel_option bisim) tls1 tls2"
  and "tfinite tls1"
  and "terminal tls1 = Some s1'"
  and "final1 s1'"
  shows "s2'. tfinite tls2  terminal tls2 = Some s2'  final2 s2'"
using assms(4) assms(1-3,5-)
apply(induct arbitrary: tls2 s1 s2 rule: tfinite_induct)
apply(auto 4 4 simp add: tllist_all2_TCons1 tllist_all2_TNil1 rel_option_Some1 trsys1.τRuns_simps trsys2.τRuns_simps dest: final1_simulation elim: converse_rtranclpE)
done

lemma τRuns_terminate_final2:
  " s1 ⇓1 tls1; s2 ⇓2 tls2; tllist_all2 tlsim (rel_option bisim) tls1 tls2;
     tfinite tls2; terminal tls2 = Some s2'; final2 s2' 
   s1'. tfinite tls1  terminal tls1 = Some s1'  final1 s1'"
using delay_bisimulation_final_base.τRuns_terminate_final1[where tlsim = "flip tlsim", OF delay_bisimulation_final_base_flip]
unfolding flip_simps by -

end

locale delay_bisimulation_diverge_final = 
  delay_bisimulation_diverge + 
  delay_bisimulation_final_base +
  constrains trsys1 :: "('s1, 'tl1) trsys"
  and trsys2 :: "('s2, 'tl2) trsys"
  and bisim :: "('s1, 's2) bisim"
  and tlsim :: "('tl1, 'tl2) bisim"
  and τmove1 :: "('s1, 'tl1) trsys"
  and τmove2 :: "('s2, 'tl2) trsys"
  and final1 :: "'s1  bool"
  and final2 :: "'s2  bool"
begin

lemma delay_bisimulation_diverge_final_flip:
  "delay_bisimulation_diverge_final trsys2 trsys1 (flip bisim) (flip tlsim) τmove2 τmove1 final2 final1"
apply(rule delay_bisimulation_diverge_final.intro)
 apply(rule delay_bisimulation_diverge_flip)
apply(unfold_locales, unfold flip_simps)
apply(blast intro: final1_simulation final2_simulation)+
done

end

lemma delay_bisimulation_diverge_final_flip_simps [flip_simps]:
  "delay_bisimulation_diverge_final trsys2 trsys1 (flip bisim) (flip tlsim) τmove2 τmove1 final2 final1 =
   delay_bisimulation_diverge_final trsys1 trsys2 bisim tlsim τmove1 τmove2 final1 final2"
by(auto dest: delay_bisimulation_diverge_final.delay_bisimulation_diverge_final_flip simp only: flip_flip)

context delay_bisimulation_diverge_final begin

lemma delay_bisimulation_diverge:
  "delay_bisimulation_diverge trsys1 trsys2 bisim tlsim τmove1 τmove2"
by(unfold_locales)

lemma delay_bisimulation_final_base:
  "delay_bisimulation_final_base trsys1 trsys2 bisim τmove1 τmove2 final1 final2"
by(unfold_locales)

lemma final_simulation1:
  " s1  s2; s1 -τ1-tls1→* s1'; final1 s1' 
   s2' tls2. s2 -τ2-tls2→* s2'  s1'  s2'  final2 s2'  tls1 [∼] tls2"
by(blast dest: simulation1_τrtrancl3p final1_simulation intro: τrtrancl3p_trans[OF _ silent_moves_into_τrtrancl3p, simplified])

lemma final_simulation2:
  " s1  s2; s2 -τ2-tls2→* s2'; final2 s2' 
   s1' tls1. s1 -τ1-tls1→* s1'  s1'  s2'  final1 s1'  tls1 [∼] tls2"
by(rule delay_bisimulation_diverge_final.final_simulation1[OF delay_bisimulation_diverge_final_flip, unfolded flip_simps])

end

locale delay_bisimulation_measure_base = 
  delay_bisimulation_base +
  constrains trsys1 :: "'s1  'tl1  's1  bool"
  and trsys2 :: "'s2  'tl2  's2  bool"
  and bisim :: "'s1  's2  bool"
  and tlsim :: "'tl1  'tl2  bool"
  and τmove1 :: "'s1  'tl1  's1  bool"
  and τmove2 :: "'s2  'tl2  's2  bool"
  fixes μ1 :: "'s1  's1  bool"
  and μ2 :: "'s2  's2  bool"

locale delay_bisimulation_measure =
  delay_bisimulation_measure_base _ _ _ _ τmove1 τmove2 μ1 μ2 +
  delay_bisimulation_obs trsys1 trsys2 bisim tlsim τmove1 τmove2
  for τmove1 :: "'s1  'tl1  's1  bool"
  and τmove2 :: "'s2  'tl2  's2  bool"
  and μ1 :: "'s1  's1  bool"
  and μ2 :: "'s2  's2  bool" +
  assumes simulation_silent1:
  " s1  s2; s1 -τ1→ s1'   s1'  s2  μ1^++ s1' s1  (s2'. s2 -τ2→+ s2'  s1'  s2')"
  and simulation_silent2:
  " s1  s2; s2 -τ2→ s2'   s1  s2'  μ2^++ s2' s2  (s1'. s1 -τ1→+ s1'  s1'  s2')"
  and wf_μ1: "wfP μ1"
  and wf_μ2: "wfP μ2"
begin

lemma delay_bisimulation_measure_flip:
  "delay_bisimulation_measure trsys2 trsys1 (flip bisim) (flip tlsim) τmove2 τmove1 μ2 μ1"
apply(rule delay_bisimulation_measure.intro)
 apply(rule delay_bisimulation_obs_flip)
apply(unfold_locales)
apply(unfold flip_simps)
apply(rule simulation_silent1 simulation_silent2 wf_μ1 wf_μ2|assumption)+
done

end

lemma delay_bisimulation_measure_flip_simps [flip_simps]:
  "delay_bisimulation_measure trsys2 trsys1 (flip bisim) (flip tlsim) τmove2 τmove1 μ2 μ1 =
   delay_bisimulation_measure trsys1 trsys2 bisim tlsim τmove1 τmove2 μ1 μ2"
by(auto dest: delay_bisimulation_measure.delay_bisimulation_measure_flip simp only: flip_simps)

context delay_bisimulation_measure begin

lemma simulation_silentst1:
  assumes bisim: "s1  s2" and moves: "s1 -τ1→+ s1'"
  shows "s1'  s2  μ1^++ s1' s1  (s2'. s2 -τ2→+ s2'  s1'  s2')"
using moves bisim
proof induct
  case (base s1') thus ?case by(auto dest: simulation_silent1)
next
  case (step s1' s1'')
  hence "s1'  s2  μ1++ s1' s1  (s2'. s2 -τ2→+ s2'  s1'  s2')" by blast
  thus ?case
  proof
    assume "s1'  s2  μ1++ s1' s1"
    hence "s1'  s2" "μ1++ s1' s1" by simp_all
    with simulation_silent1[OF s1'  s2 s1' -τ1→ s1'']
    show ?thesis by(auto)
  next
    assume "s2'. trsys2.silent_move++ s2 s2'  s1'  s2'"
    then obtain s2' where "s2 -τ2→+ s2'" "s1'  s2'" by blast
    with simulation_silent1[OF s1'  s2' s1' -τ1→ s1'']
    show ?thesis by(auto intro: tranclp_trans)
  qed
qed

lemma simulation_silentst2:
  " s1  s2; s2 -τ2→+ s2'   s1  s2'  μ2^++ s2' s2  (s1'. s1 -τ1→+ s1'  s1'  s2')"
using delay_bisimulation_measure.simulation_silentst1[OF delay_bisimulation_measure_flip]
unfolding flip_simps .

lemma τdiverge_simulation1:
  assumes diverge1: "s1 -τ1→ "
  and bisim: "s1  s2"
  shows "s2 -τ2→ "
proof -
  from assms have "s1 -τ1→   s1  s2" by blast
  thus ?thesis using wfP_trancl[OF wf_μ1]
  proof(coinduct rule: trsys2.τdiverge_trancl_measure_coinduct)
    case (τdiverge s2 s1)
    hence "s1 -τ1→ " "s1  s2" by simp_all
    then obtain s1' where "trsys1.silent_move s1 s1'" "s1' -τ1→ "
      by(fastforce elim: trsys1.τdiverge.cases)
    from simulation_silent1[OF s1  s2 ‹trsys1.silent_move s1 s1'] s1' -τ1→ 
    show ?case by auto
  qed
qed

lemma τdiverge_simulation2:
  " s2 -τ2→ ; s1  s2   s1 -τ1→ "
using delay_bisimulation_measure.τdiverge_simulation1[OF delay_bisimulation_measure_flip]
unfolding flip_simps .

lemma τdiverge_bisim_inv:
  "s1  s2  s1 -τ1→   s2 -τ2→ "
by(blast intro: τdiverge_simulation1 τdiverge_simulation2)

end

sublocale delay_bisimulation_measure < delay_bisimulation_diverge
proof
  fix s1 s2 s1'
  assume "s1  s2" "s1 -τ1→ s1'"
  from simulation_silent1[OF this]
  show "s2'. s2 -τ2→* s2'  s1'  s2'" by(auto intro: tranclp_into_rtranclp)
next
  fix s1 s2 s2'
  assume "s1  s2" "s2 -τ2→ s2'"
  from simulation_silent2[OF this]
  show "s1'. s1 -τ1→* s1'  s1'  s2'" by(auto intro: tranclp_into_rtranclp)
next
  fix s1 s2
  assume "s1  s2"
  thus "s1 -τ1→   s2 -τ2→ " by(rule τdiverge_bisim_inv)
qed

text ‹
  Counter example for
  @{prop "delay_bisimulation_diverge trsys1 trsys2 bisim tlsim τmove1 τmove2  μ1 μ2. delay_bisimulation_measure trsys1 trsys2 bisim tlsim τmove1 τmove2 μ1 μ2"}

 (only τ›moves):
\begin{verbatim}
--|
| v
--a  ~  x
  |     |
  |     |
  v     v
--b  ~  y--
| ^     ^ |
--|     |--
\end{verbatim}
›

locale delay_bisimulation_measure_final =
  delay_bisimulation_measure + 
  delay_bisimulation_final_base +
  constrains trsys1 :: "('s1, 'tl1) trsys"
  and trsys2 :: "('s2, 'tl2) trsys"
  and bisim :: "('s1, 's2) bisim"
  and tlsim :: "('tl1, 'tl2) bisim"
  and τmove1 :: "('s1, 'tl1) trsys"
  and τmove2 :: "('s2, 'tl2) trsys"
  and μ1 :: "'s1  's1  bool"
  and μ2 :: "'s2  's2  bool"
  and final1 :: "'s1  bool"
  and final2 :: "'s2  bool"

sublocale delay_bisimulation_measure_final < delay_bisimulation_diverge_final
by unfold_locales

locale τinv = delay_bisimulation_base +
  constrains trsys1 :: "('s1, 'tl1) trsys"
  and trsys2 :: "('s2, 'tl2) trsys"
  and bisim :: "('s1, 's2) bisim"
  and tlsim :: "('tl1, 'tl2) bisim"
  and τmove1 :: "('s1, 'tl1) trsys"
  and τmove2 :: "('s2, 'tl2) trsys"
  and τmoves1 :: "'s1  's1  bool"
  and τmoves2 :: "'s2  's2  bool"
  assumes τinv: " s1  s2; s1 -1-tl1 s1'; s2 -2-tl2 s2'; s1'  s2'; tl1  tl2 
                  τmove1 s1 tl1 s1'  τmove2 s2 tl2 s2'"
begin

lemma τinv_flip:
  "τinv trsys2 trsys1 (flip bisim) (flip tlsim) τmove2 τmove1"
by(unfold_locales)(unfold flip_simps,rule τinv[symmetric])

end

lemma τinv_flip_simps [flip_simps]:
  "τinv trsys2 trsys1 (flip bisim) (flip tlsim) τmove2 τmove1 = τinv trsys1 trsys2 bisim tlsim τmove1 τmove2"
by(auto dest: τinv.τinv_flip simp only: flip_simps)

locale bisimulation_into_delay =
  bisimulation + τinv +
  constrains trsys1 :: "('s1, 'tl1) trsys"
  and trsys2 :: "('s2, 'tl2) trsys"
  and bisim :: "('s1, 's2) bisim"
  and tlsim :: "('tl1, 'tl2) bisim"
  and τmove1 :: "('s1, 'tl1) trsys"
  and τmove2 :: "('s2, 'tl2) trsys"
begin

lemma bisimulation_into_delay_flip:
  "bisimulation_into_delay trsys2 trsys1 (flip bisim) (flip tlsim) τmove2 τmove1"
by(intro_locales)(intro bisimulation_flip τinv_flip)+

end

lemma bisimulation_into_delay_flip_simps [flip_simps]:
  "bisimulation_into_delay trsys2 trsys1 (flip bisim) (flip tlsim) τmove2 τmove1 =
   bisimulation_into_delay trsys1 trsys2 bisim tlsim τmove1 τmove2"
by(auto dest: bisimulation_into_delay.bisimulation_into_delay_flip simp only: flip_simps)

context bisimulation_into_delay begin

lemma simulation_silent1_aux:
  assumes bisim: "s1  s2" and "s1 -τ1→ s1'"
  shows "s1'  s2  μ1++ s1' s1  (s2'. s2 -τ2→+ s2'  s1'  s2')"
proof -
  from assms obtain tl1 where tr1: "s1 -1-tl1 s1'"
    and τ1: "τmove1 s1 tl1 s1'" by(auto)
  from simulation1[OF bisim tr1]
  obtain s2' tl2 where tr2: "s2 -2-tl2 s2'"
    and bisim': "s1'  s2'" and tlsim: "tl1  tl2" by blast
  from τinv[OF bisim tr1 tr2 bisim' tlsim] τ1 have τ2: "τmove2 s2 tl2 s2'" by simp
  from tr2 τ2 have "s2 -τ2→+ s2'" by(auto)
  with bisim' show ?thesis by blast
qed

lemma simulation_silent2_aux:
  " s1  s2; s2 -τ2→ s2'   s1  s2'  μ2++ s2' s2  (s1'. s1 -τ1→+ s1'  s1'  s2')"
using bisimulation_into_delay.simulation_silent1_aux[OF bisimulation_into_delay_flip]
unfolding flip_simps .

lemma simulation1_aux:
  assumes bisim: "s1  s2" and tr1: "s1 -1-tl1 s1'" and τ1: "¬ τmove1 s1 tl1 s1'"
  shows "s2' s2'' tl2. s2 -τ2→* s2'  s2' -2-tl2 s2''  ¬ τmove2 s2' tl2 s2''  s1'  s2''  tl1  tl2"
proof -
  from simulation1[OF bisim tr1]
  obtain s2' tl2 where tr2: "s2 -2-tl2 s2'"
    and bisim': "s1'  s2'" and tlsim: "tl1  tl2" by blast
  from τinv[OF bisim tr1 tr2 bisim' tlsim] τ1 have τ2: "¬ τmove2 s2 tl2 s2'" by simp
  with bisim' tr2 tlsim show ?thesis by blast
qed

lemma simulation2_aux:
  " s1  s2; s2 -2-tl2 s2'; ¬ τmove2 s2 tl2 s2' 
   s1' s1'' tl1. s1 -τ1→* s1'  s1' -1-tl1 s1''  ¬ τmove1 s1' tl1 s1''  s1''  s2'  tl1  tl2"
using bisimulation_into_delay.simulation1_aux[OF bisimulation_into_delay_flip]
unfolding flip_simps .

lemma delay_bisimulation_measure:
  assumes wf_μ1: "wfP μ1"
  and wf_μ2: "wfP μ2"
  shows "delay_bisimulation_measure trsys1 trsys2 bisim tlsim τmove1 τmove2 μ1 μ2"
apply(unfold_locales)
apply(rule simulation_silent1_aux simulation_silent2_aux simulation1_aux simulation2_aux wf_μ1 wf_μ2|assumption)+
done

lemma delay_bisimulation:
  "delay_bisimulation_diverge trsys1 trsys2 bisim tlsim τmove1 τmove2"
proof -
  interpret delay_bisimulation_measure trsys1 trsys2 bisim tlsim τmove1 τmove2 "λs s'. False" "λs s'. False"
    by(blast intro: delay_bisimulation_measure wfP_empty)
  show ?thesis ..
qed

end

sublocale bisimulation_into_delay < delay_bisimulation_diverge
by(rule delay_bisimulation)

lemma delay_bisimulation_conv_bisimulation:
  "delay_bisimulation_diverge trsys1 trsys2 bisim tlsim (λs tl s'. False) (λs tl s'. False) =
   bisimulation trsys1 trsys2 bisim tlsim"
  (is "?lhs = ?rhs")
proof
  assume ?lhs
  then interpret delay_bisimulation_diverge trsys1 trsys2 bisim tlsim "λs tl s'. False" "λs tl s'. False" .
  show ?rhs by(unfold_locales)(fastforce simp add: τmoves_False dest: simulation1 simulation2)+
next
  assume ?rhs
  then interpret bisimulation trsys1 trsys2 bisim tlsim .
  interpret bisimulation_into_delay trsys1 trsys2 bisim tlsim "λs tl s'. False" "λs tl s'. False"
    by(unfold_locales)(rule refl)
  show ?lhs by unfold_locales
qed

context bisimulation_final begin

lemma delay_bisimulation_final_base: 
  "delay_bisimulation_final_base trsys1 trsys2 bisim τmove1 τmove2 final1 final2"
by(unfold_locales)(auto simp add: bisim_final)

end

sublocale bisimulation_final < delay_bisimulation_final_base
by(rule delay_bisimulation_final_base)

subsection ‹Transitivity for bisimulations›

definition bisim_compose :: "('s1, 's2) bisim  ('s2, 's3) bisim  ('s1, 's3) bisim" (infixr "B" 60)
where "(bisim1 B bisim2) s1 s3  s2. bisim1 s1 s2  bisim2 s2 s3"

lemma bisim_composeI [intro]:
  " bisim12 s1 s2; bisim23 s2 s3   (bisim12 B bisim23) s1 s3"
by(auto simp add: bisim_compose_def)

lemma bisim_composeE [elim!]:
  assumes bisim: "(bisim12 B bisim23) s1 s3"
  obtains s2 where "bisim12 s1 s2" "bisim23 s2 s3"
by(atomize_elim)(rule bisim[unfolded bisim_compose_def])

lemma bisim_compose_assoc [simp]:
  "(bisim12 B bisim23) B bisim34 = bisim12 B bisim23 B bisim34"
by(auto simp add: fun_eq_iff)

lemma bisim_compose_conv_relcomp:
  "case_prod (bisim_compose bisim12 bisim23) = (λx. x  relcomp (Collect (case_prod bisim12)) (Collect (case_prod bisim23)))"
by(auto simp add: relcomp_unfold)

lemma list_all2_bisim_composeI:
  " list_all2 A xs ys; list_all2 B ys zs 
   list_all2 (A B B) xs zs"
by(rule list_all2_trans) auto+

lemma delay_bisimulation_diverge_compose:
  assumes wbisim12: "delay_bisimulation_diverge trsys1 trsys2 bisim12 tlsim12 τmove1 τmove2"
  and wbisim23: "delay_bisimulation_diverge trsys2 trsys3 bisim23 tlsim23 τmove2 τmove3"
  shows "delay_bisimulation_diverge trsys1 trsys3 (bisim12 B bisim23) (tlsim12 B tlsim23) τmove1 τmove3"
proof -
  interpret trsys1: τtrsys trsys1 τmove1 .
  interpret trsys2: τtrsys trsys2 τmove2 .
  interpret trsys3: τtrsys trsys3 τmove3 .
  interpret wb12: delay_bisimulation_diverge trsys1 trsys2 bisim12 tlsim12 τmove1 τmove2 by(auto intro: wbisim12)
  interpret wb23: delay_bisimulation_diverge trsys2 trsys3 bisim23 tlsim23 τmove2 τmove3 by(auto intro: wbisim23)
  show ?thesis
  proof
    fix s1 s3 s1'
    assume bisim: "(bisim12 B bisim23) s1 s3" and tr1: "trsys1.silent_move s1 s1'"
    from bisim obtain s2 where bisim1: "bisim12 s1 s2" and bisim2: "bisim23 s2 s3" by blast
    from wb12.simulation_silent1[OF bisim1 tr1] obtain s2'
      where tr2: "trsys2.silent_moves s2 s2'" and bisim1': "bisim12 s1' s2'" by blast
    from wb23.simulation_silents1[OF bisim2 tr2] obtain s3'
      where "trsys3.silent_moves s3 s3'" "bisim23 s2' s3'" by blast
    with bisim1' show "s3'. trsys3.silent_moves s3 s3'  (bisim12 B bisim23) s1' s3'"
      by(blast intro: bisim_composeI)
  next
    fix s1 s3 s3'
    assume bisim: "(bisim12 B bisim23) s1 s3" and tr3: "trsys3.silent_move s3 s3'"
    from bisim obtain s2 where bisim1: "bisim12 s1 s2" and bisim2: "bisim23 s2 s3" by blast
    from wb23.simulation_silent2[OF bisim2 tr3] obtain s2'
      where tr2: "trsys2.silent_moves s2 s2'" and bisim2': "bisim23 s2' s3'" by blast
    from wb12.simulation_silents2[OF bisim1 tr2] obtain s1'
      where "trsys1.silent_moves s1 s1'" "bisim12 s1' s2'" by blast
    with bisim2' show "s1'. trsys1.silent_moves s1 s1'  (bisim12 B bisim23) s1' s3'"
      by(blast intro: bisim_composeI)
  next
    fix s1 s3 tl1 s1'
    assume bisim: "(bisim12 B bisim23) s1 s3"
      and tr1: "trsys1 s1 tl1 s1'" and τ1: "¬ τmove1 s1 tl1 s1'"
    from bisim obtain s2 where bisim1: "bisim12 s1 s2" and bisim2: "bisim23 s2 s3" by blast
    from wb12.simulation1[OF bisim1 tr1 τ1] obtain s2' s2'' tl2
      where tr21: "trsys2.silent_moves s2 s2'" and tr22: "trsys2 s2' tl2 s2''" and τ2: "¬ τmove2 s2' tl2 s2''"
      and bisim1': "bisim12 s1' s2''" and tlsim1: "tlsim12 tl1 tl2" by blast
    from wb23.simulation_silents1[OF bisim2 tr21] obtain s3'
      where tr31: "trsys3.silent_moves s3 s3'" and bisim2': "bisim23 s2' s3'" by blast
    from wb23.simulation1[OF bisim2' tr22 τ2] obtain s3'' s3''' tl3
      where "trsys3.silent_moves s3' s3''" "trsys3 s3'' tl3 s3'''"
      "¬ τmove3 s3'' tl3 s3'''" "bisim23 s2'' s3'''" "tlsim23 tl2 tl3" by blast
    with tr31 bisim1' tlsim1 
    show "s3' s3'' tl3. trsys3.silent_moves s3 s3'  trsys3 s3' tl3 s3''  ¬ τmove3 s3' tl3 s3'' 
                         (bisim12 B bisim23) s1' s3''  (tlsim12 B tlsim23) tl1 tl3"
      by(blast intro: rtranclp_trans bisim_composeI)
  next
    fix s1 s3 tl3 s3'
    assume bisim: "(bisim12 B bisim23) s1 s3"
      and tr3: "trsys3 s3 tl3 s3'" and τ3: "¬ τmove3 s3 tl3 s3'"
    from bisim obtain s2 where bisim1: "bisim12 s1 s2" and bisim2: "bisim23 s2 s3" by blast
    from wb23.simulation2[OF bisim2 tr3 τ3] obtain s2' s2'' tl2
      where tr21: "trsys2.silent_moves s2 s2'" and tr22: "trsys2 s2' tl2 s2''" and τ2: "¬ τmove2 s2' tl2 s2''"
      and bisim2': "bisim23 s2'' s3'" and tlsim2: "tlsim23 tl2 tl3" by blast
    from wb12.simulation_silents2[OF bisim1 tr21] obtain s1'
      where tr11: "trsys1.silent_moves s1 s1'" and bisim1': "bisim12 s1' s2'" by blast
    from wb12.simulation2[OF bisim1' tr22 τ2] obtain s1'' s1''' tl1
      where "trsys1.silent_moves s1' s1''" "trsys1 s1'' tl1 s1'''"
      "¬ τmove1 s1'' tl1 s1'''" "bisim12 s1''' s2''" "tlsim12 tl1 tl2" by blast
    with tr11 bisim2' tlsim2
    show "s1' s1'' tl1. trsys1.silent_moves s1 s1'  trsys1 s1' tl1 s1''  ¬ τmove1 s1' tl1 s1'' 
                         (bisim12 B bisim23) s1'' s3'  (tlsim12 B tlsim23) tl1 tl3"
      by(blast intro: rtranclp_trans bisim_composeI)
  next
    fix s1 s2
    assume "(bisim12 B bisim23) s1 s2"
    thus "τtrsys.τdiverge trsys1 τmove1 s1 = τtrsys.τdiverge trsys3 τmove3 s2"
      by(auto simp add: wb12.τdiverge_bisim_inv wb23.τdiverge_bisim_inv)
  qed
qed

lemma bisimulation_bisim_compose:
  " bisimulation trsys1 trsys2 bisim12 tlsim12; bisimulation trsys2 trsys3 bisim23 tlsim23 
   bisimulation trsys1 trsys3 (bisim_compose bisim12 bisim23) (bisim_compose tlsim12 tlsim23)"
unfolding delay_bisimulation_conv_bisimulation[symmetric]
by(rule delay_bisimulation_diverge_compose)

lemma delay_bisimulation_diverge_final_compose:
  fixes τmove1 τmove2
  assumes wbisim12: "delay_bisimulation_diverge_final trsys1 trsys2 bisim12 tlsim12 τmove1 τmove2 final1 final2"
  and wbisim23: "delay_bisimulation_diverge_final trsys2 trsys3 bisim23 tlsim23 τmove2 τmove3 final2 final3"
  shows "delay_bisimulation_diverge_final trsys1 trsys3 (bisim12 B bisim23) (tlsim12 B tlsim23) τmove1 τmove3 final1 final3"
proof -
  interpret trsys1: τtrsys trsys1 τmove1 .
  interpret trsys2: τtrsys trsys2 τmove2 .
  interpret trsys3: τtrsys trsys3 τmove3 .
  interpret wb12: delay_bisimulation_diverge_final trsys1 trsys2 bisim12 tlsim12 τmove1 τmove2 final1 final2
    by(auto intro: wbisim12)
  interpret wb23: delay_bisimulation_diverge_final trsys2 trsys3 bisim23 tlsim23 τmove2 τmove3 final2 final3
    by(auto intro: wbisim23)
  interpret delay_bisimulation_diverge trsys1 trsys3 "bisim12 B bisim23" "tlsim12 B tlsim23" τmove1 τmove3
    by(rule delay_bisimulation_diverge_compose)(unfold_locales)
  show ?thesis
  proof
    fix s1 s3
    assume "(bisim12 B bisim23) s1 s3" "final1 s1"
    from (bisim12 B bisim23) s1 s3 obtain s2 where "bisim12 s1 s2" and "bisim23 s2 s3" ..
    from wb12.final1_simulation[OF bisim12 s1 s2 final1 s1]
    obtain s2' where "trsys2.silent_moves s2 s2'" "bisim12 s1 s2'" "final2 s2'" by blast
    from wb23.simulation_silents1[OF bisim23 s2 s3 ‹trsys2.silent_moves s2 s2']
    obtain s3' where "trsys3.silent_moves s3 s3'" "bisim23 s2' s3'" by blast
    from wb23.final1_simulation[OF bisim23 s2' s3' final2 s2']
    obtain s3'' where "trsys3.silent_moves s3' s3''" "bisim23 s2' s3''" "final3 s3''" by blast
    from ‹trsys3.silent_moves s3 s3' ‹trsys3.silent_moves s3' s3''
    have "trsys3.silent_moves s3 s3''" by(rule rtranclp_trans)
    moreover from bisim12 s1 s2' bisim23 s2' s3''
    have "(bisim12 B bisim23) s1 s3''" ..
    ultimately show "s3'. trsys3.silent_moves s3 s3'  (bisim12 B bisim23) s1 s3'  final3 s3'"
      using final3 s3'' by iprover
  next
    fix s1 s3
    assume "(bisim12 B bisim23) s1 s3" "final3 s3"
    from (bisim12 B bisim23) s1 s3 obtain s2 where "bisim12 s1 s2" and "bisim23 s2 s3" ..
    from wb23.final2_simulation[OF bisim23 s2 s3 final3 s3]
    obtain s2' where "trsys2.silent_moves s2 s2'" "bisim23 s2' s3" "final2 s2'" by blast
    from wb12.simulation_silents2[OF bisim12 s1 s2 ‹trsys2.silent_moves s2 s2']
    obtain s1' where "trsys1.silent_moves s1 s1'" "bisim12 s1' s2'" by blast
    from wb12.final2_simulation[OF bisim12 s1' s2' final2 s2']
    obtain s1'' where "trsys1.silent_moves s1' s1''" "bisim12 s1'' s2'" "final1 s1''" by blast
    from ‹trsys1.silent_moves s1 s1' ‹trsys1.silent_moves s1' s1''
    have "trsys1.silent_moves s1 s1''" by(rule rtranclp_trans)
    moreover from bisim12 s1'' s2' bisim23 s2' s3
    have "(bisim12 B bisim23) s1'' s3" ..
    ultimately show "s1'. trsys1.silent_moves s1 s1'  (bisim12 B bisim23) s1' s3  final1 s1'"
      using final1 s1'' by iprover
  qed
qed

end

Theory FWBisimulation

(*  Title:      JinjaThreads/Framework/FWBisimulation.thy
    Author:     Andreas Lochbihler
*)

section ‹Bisimulation relations for the multithreaded semantics›

theory FWBisimulation
imports
  FWLTS
  Bisimulation
begin

subsection ‹Definitions for lifting bisimulation relations›

primrec nta_bisim :: "('t  ('x1 × 'm1, 'x2 × 'm2) bisim)  (('t,'x1,'m1) new_thread_action, ('t,'x2,'m2) new_thread_action) bisim"
  where
  [code del]: "nta_bisim bisim (NewThread t x m) ta = (x' m'. ta = NewThread t x' m'  bisim t (x, m) (x', m'))"
| "nta_bisim bisim (ThreadExists t b) ta = (ta = ThreadExists t b)"

lemma nta_bisim_1_code [code]:
  "nta_bisim bisim (NewThread t x m) ta = (case ta of NewThread t' x' m'  t = t'  bisim t (x, m) (x', m') | _  False)"
by(auto split: new_thread_action.split)
  
lemma nta_bisim_simps_sym [simp]:
  "nta_bisim bisim ta (NewThread t x m) = (x' m'. ta = NewThread t x' m'  bisim t (x', m') (x, m))"
  "nta_bisim bisim ta (ThreadExists t b) = (ta = ThreadExists t b)"
by(cases ta, auto)+

definition ta_bisim :: "('t  ('x1 × 'm1, 'x2 × 'm2) bisim)  (('l,'t,'x1,'m1,'w,'o) thread_action, ('l,'t,'x2,'m2,'w,'o) thread_action) bisim"
where
  "ta_bisim bisim ta1 ta2 
   ta1l =  ta2l   ta1w =  ta2w   ta1c =  ta2c   ta1o =  ta2o   ta1i =  ta2i 
  list_all2 (nta_bisim bisim)  ta1t  ta2t"

lemma ta_bisim_empty [iff]: "ta_bisim bisim ε ε"
by(auto simp add: ta_bisim_def)

lemma ta_bisim_ε [simp]:
  "ta_bisim b ε ta'  ta' = ε" "ta_bisim b ta ε  ta = ε"
apply(cases ta', fastforce simp add: ta_bisim_def)
apply(cases ta, fastforce simp add: ta_bisim_def)
done

lemma nta_bisim_mono:
  assumes major: "nta_bisim bisim ta ta'"
  and mono: "t s1 s2. bisim t s1 s2  bisim' t s1 s2"
  shows "nta_bisim bisim' ta ta'"
using major by(cases ta)(auto intro: mono)

lemma ta_bisim_mono:
  assumes major: "ta_bisim bisim ta1 ta2"
  and mono: "t s1 s2. bisim t s1 s2  bisim' t s1 s2"
  shows "ta_bisim bisim' ta1 ta2"
using major
by(auto simp add: ta_bisim_def elim!: List.list_all2_mono nta_bisim_mono intro: mono)

lemma nta_bisim_flip [flip_simps]:
  "nta_bisim (λt. flip (bisim t)) = flip (nta_bisim bisim)"
by(rule ext)(case_tac x, auto simp add: flip_simps)

lemma ta_bisim_flip [flip_simps]:
  "ta_bisim (λt. flip (bisim t)) = flip (ta_bisim bisim)"
by(auto simp add: fun_eq_iff flip_simps ta_bisim_def)

locale FWbisimulation_base =
  r1: multithreaded_base final1 r1 convert_RA +
  r2: multithreaded_base final2 r2 convert_RA 
  for final1 :: "'x1  bool"
  and r1 :: "('l,'t,'x1,'m1,'w,'o) semantics" ("_  _ -1-_ _" [50, 0, 0, 50] 80)
  and final2 :: "'x2  bool"
  and r2 :: "('l,'t,'x2,'m2,'w,'o) semantics" ("_  _ -2-_ _" [50, 0, 0, 50] 80) 
  and convert_RA :: "'l released_locks  'o list"
  +
  fixes bisim :: "'t  ('x1 × 'm1, 'x2 × 'm2) bisim" ("_  _/  _" [50, 50, 50] 60)
  and bisim_wait :: "('x1, 'x2) bisim" ("_/ ≈w _" [50, 50] 60)
begin

notation r1.redT_syntax1 ("_ -1-__ _" [50,0,0,50] 80)
notation r2.redT_syntax1 ("_ -2-__ _" [50,0,0,50] 80)

notation r1.RedT ("_ -1-▹_→* _" [50,0,50] 80)
notation r2.RedT ("_ -2-▹_→* _" [50,0,50] 80)

notation r1.must_sync ("_  _,/ _/ ≀1" [50,0,0] 81)
notation r2.must_sync ("_  _,/ _/ ≀2" [50,0,0] 81)

notation r1.can_sync  ("_  _,/ _/ _/ ≀1" [50,0,0,0] 81)
notation r2.can_sync  ("_  _,/ _/ _/ ≀2" [50,0,0,0] 81)

abbreviation ta_bisim_bisim_syntax ("_/ ∼m _" [50, 50] 60)
where "ta1 ∼m ta2  ta_bisim bisim ta1 ta2"

definition tbisim :: "bool  't  ('x1 × 'l released_locks) option  'm1  ('x2 × 'l released_locks) option  'm2  bool" where
  "ln. tbisim nw t ts1 m1 ts2 m2 
  (case ts1 of None  ts2 = None
       | (x1, ln)  (x2. ts2 = (x2, ln)  t  (x1, m1)  (x2, m2)  (nw  x1 ≈w x2)))"

lemma tbisim_NoneI: "tbisim w t None m None m'"
by(simp add: tbisim_def)

lemma tbisim_SomeI:
  "ln.  t  (x, m)  (x', m'); nw  x ≈w x'   tbisim nw t (Some (x, ln)) m (Some (x', ln)) m'"
by(simp add: tbisim_def)

lemma tbisim_cases[consumes 1, case_names None Some]:
  assumes major: "tbisim nw t ts1 m1 ts2 m2"
  and " ts1 = None; ts2 = None   thesis"
  and "x ln x'.  ts1 = (x, ln); ts2 = (x', ln); t  (x, m1)  (x', m2); nw  x ≈w x'   thesis"
  shows thesis
using assms
by(auto simp add: tbisim_def)

definition mbisim :: "(('l,'t,'x1,'m1,'w) state, ('l,'t,'x2,'m2,'w) state) bisim" ("_ ≈m _" [50, 50] 60)
where
  "s1 ≈m s2  
  finite (dom (thr s1))  locks s1 = locks s2  wset s1 = wset s2  wset_thread_ok (wset s1) (thr s1) 
  interrupts s1 = interrupts s2 
  (t. tbisim (wset s2 t = None) t (thr s1 t) (shr s1) (thr s2 t) (shr s2))"

lemma mbisim_thrNone_eq: "s1 ≈m s2  thr s1 t = None  thr s2 t = None"
unfolding mbisim_def tbisim_def
apply(clarify)
apply(erule allE[where x=t])
apply(clarsimp)
done

lemma mbisim_thrD1:
  "ln.  s1 ≈m s2; thr s1 t = (x, ln) 
   x'. thr s2 t = (x', ln)  t  (x, shr s1)  (x', shr s2)  (wset s1 t = None  x ≈w x')"
by(fastforce simp add: mbisim_def tbisim_def)

lemma mbisim_thrD2:
  "ln.  s1 ≈m s2; thr s2 t = (x, ln) 
   x'. thr s1 t = (x', ln)  t  (x', shr s1)  (x, shr s2)  (wset s2 t = None  x' ≈w x)"
by(frule mbisim_thrNone_eq[where t=t])(cases "thr s1 t",(fastforce simp add: mbisim_def tbisim_def)+)

lemma mbisim_dom_eq: "s1 ≈m s2  dom (thr s1) = dom (thr s2)"
apply(clarsimp simp add: dom_def fun_eq_iff simp del: not_None_eq)
apply(rule Collect_cong)
apply(drule mbisim_thrNone_eq)
apply(simp del: not_None_eq)
done

lemma mbisim_wset_thread_ok1:
  "s1 ≈m s2  wset_thread_ok (wset s1) (thr s1)"
by(clarsimp simp add: mbisim_def)

lemma mbisim_wset_thread_ok2:
  assumes "s1 ≈m s2"
  shows "wset_thread_ok (wset s2) (thr s2)"
using assms
apply(clarsimp simp add: mbisim_def)
apply(auto intro!: wset_thread_okI simp add: mbisim_thrNone_eq[OF assms, THEN sym] dest: wset_thread_okD)
done

lemma mbisimI:
  " finite (dom (thr s1)); locks s1 = locks s2; wset s1 = wset s2; interrupts s1 = interrupts s2; 
     wset_thread_ok (wset s1) (thr s1);
     t. thr s1 t = None  thr s2 t = None;
     t x1 ln. thr s1 t = (x1, ln)  x2. thr s2 t = (x2, ln)  t  (x1, shr s1)  (x2, shr s2)  (wset s2 t = None  x1 ≈w x2) 
   s1 ≈m s2"
by(fastforce simp add: mbisim_def tbisim_def)

lemma mbisimI2:
  " finite (dom (thr s2)); locks s1 = locks s2; wset s1 = wset s2; interrupts s1 = interrupts s2;
     wset_thread_ok (wset s2) (thr s2);
     t. thr s2 t = None  thr s1 t = None;
     t x2 ln. thr s2 t = (x2, ln)  x1. thr s1 t = (x1, ln)  t  (x1, shr s1)  (x2, shr s2)  (wset s2 t = None  x1 ≈w x2) 
   s1 ≈m s2"
apply(auto simp add: mbisim_def tbisim_def)
   prefer 2
   apply(rule wset_thread_okI)
   apply(case_tac "thr s2 t")
    apply(auto dest!: wset_thread_okD)[1]
   apply fastforce
  apply(erule back_subst[where P=finite])
  apply(clarsimp simp add: dom_def fun_eq_iff simp del: not_None_eq)
  defer
  apply(rename_tac t)
  apply(case_tac [!] "thr s2 t")
by fastforce+

lemma mbisim_finite1:
  "s1 ≈m s2  finite (dom (thr s1))"
by(simp add: mbisim_def)

lemma mbisim_finite2:
  "s1 ≈m s2  finite (dom (thr s2))"
by(frule mbisim_finite1)(simp add: mbisim_dom_eq)

definition mta_bisim :: "('t × ('l,'t,'x1,'m1,'w,'o) thread_action,
                       't × ('l,'t,'x2,'m2,'w,'o) thread_action) bisim"
  ("_/ ∼T _" [50, 50] 60)
where "tta1 ∼T tta2  fst tta1 = fst tta2  snd tta1 ∼m snd tta2"

lemma mta_bisim_conv [simp]: "(t, ta1) ∼T (t', ta2)  t = t'  ta1 ∼m ta2"
by(simp add: mta_bisim_def)

definition bisim_inv :: "bool" where
  "bisim_inv  (s1 ta1 s1' s2 t. t  s1  s2  t  s1 -1-ta1 s1'  (s2'. t  s1'  s2')) 
               (s2 ta2 s2' s1 t. t  s1  s2  t  s2 -2-ta2 s2'  (s1'. t  s1'  s2'))"

lemma bisim_invI:
  " s1 ta1 s1' s2 t.  t  s1  s2; t  s1 -1-ta1 s1'   s2'. t  s1'  s2';
     s2 ta2 s2' s1 t.  t  s1  s2; t  s2 -2-ta2 s2'   s1'. t  s1'  s2' 
   bisim_inv"
by(auto simp add: bisim_inv_def)

lemma bisim_invD1:
  " bisim_inv; t  s1  s2; t  s1 -1-ta1 s1'   s2'. t  s1'  s2'"
unfolding bisim_inv_def by blast

lemma bisim_invD2:
  " bisim_inv; t  s1  s2; t  s2 -2-ta2 s2'   s1'. t  s1'  s2'"
unfolding bisim_inv_def by blast

lemma thread_oks_bisim_inv:
  " t. ts1 t = None  ts2 t = None; list_all2 (nta_bisim bisim) tas1 tas2 
   thread_oks ts1 tas1  thread_oks ts2 tas2"
proof(induct tas2 arbitrary: tas1 ts1 ts2)
  case Nil thus ?case by(simp)
next
  case (Cons ta2 TAS2 tas1 TS1 TS2)
  note IH = ts1 tas1 ts2.  t. ts1 t = None  ts2 t = None; list_all2 (nta_bisim bisim) tas1 TAS2 
              thread_oks ts1 tas1  thread_oks ts2 TAS2
  note eqNone = t. TS1 t = None  TS2 t = None›[rule_format]
  hence fti: "free_thread_id TS1 = free_thread_id TS2" by(auto simp add: free_thread_id_def)
  from ‹list_all2 (nta_bisim bisim) tas1 (ta2 # TAS2)
  obtain ta1 TAS1 where "tas1 = ta1 # TAS1" "nta_bisim bisim ta1 ta2" "list_all2 (nta_bisim bisim) TAS1 TAS2"
    by(auto simp add: list_all2_Cons2)
  moreover
  { fix t
    from ‹nta_bisim bisim ta1 ta2 have "redT_updT' TS1 ta1 t = None  redT_updT' TS2 ta2 t = None"
      by(cases ta1, auto split: if_split_asm simp add: eqNone) }
  ultimately have "thread_oks (redT_updT' TS1 ta1) TAS1  thread_oks (redT_updT' TS2 ta2) TAS2"
    by -(rule IH, auto)
  moreover from ‹nta_bisim bisim ta1 ta2 fti have "thread_ok TS1 ta1 = thread_ok TS2 ta2" by(cases ta1, auto)
  ultimately show ?case using tas1 = ta1 # TAS1 by auto
qed

lemma redT_updT_nta_bisim_inv:
  " nta_bisim bisim ta1 ta2; ts1 T = None  ts2 T = None   redT_updT ts1 ta1 T = None  redT_updT ts2 ta2 T = None"
by(cases ta1, auto)

lemma redT_updTs_nta_bisim_inv:
  " list_all2 (nta_bisim bisim) tas1 tas2; ts1 T = None  ts2 T = None 
   redT_updTs ts1 tas1 T = None  redT_updTs ts2 tas2 T = None"
proof(induct tas1 arbitrary: tas2 ts1 ts2)
  case Nil thus ?case by(simp)
next
  case (Cons TA1 TAS1 tas2 TS1 TS2)
  note IH = tas2 ts1 ts2. list_all2 (nta_bisim bisim) TAS1 tas2; (ts1 T = None) = (ts2 T = None)
             (redT_updTs ts1 TAS1 T = None) = (redT_updTs ts2 tas2 T = None)
  from ‹list_all2 (nta_bisim bisim) (TA1 # TAS1) tas2
  obtain TA2 TAS2 where "tas2 = TA2 # TAS2" "nta_bisim bisim TA1 TA2" "list_all2 (nta_bisim bisim) TAS1 TAS2"
    by(auto simp add: list_all2_Cons1)
  from ‹nta_bisim bisim TA1 TA2 (TS1 T = None) = (TS2 T = None)
  have "redT_updT TS1 TA1 T = None  redT_updT TS2 TA2 T = None"
    by(rule redT_updT_nta_bisim_inv)
  with IH[OF ‹list_all2 (nta_bisim bisim) TAS1 TAS2, of "redT_updT TS1 TA1" "redT_updT TS2 TA2"] tas2 = TA2 # TAS2
  show ?case by simp
qed

end

lemma tbisim_flip [flip_simps]:
  "FWbisimulation_base.tbisim (λt. flip (bisim t)) (flip bisim_wait) w t ts2 m2 ts1 m1 =
   FWbisimulation_base.tbisim bisim bisim_wait w t ts1 m1 ts2 m2"
unfolding FWbisimulation_base.tbisim_def flip_simps by auto

lemma mbisim_flip [flip_simps]:
  "FWbisimulation_base.mbisim (λt. flip (bisim t)) (flip bisim_wait) s2 s1 =
   FWbisimulation_base.mbisim bisim bisim_wait s1 s2"
apply(rule iffI)
 apply(frule FWbisimulation_base.mbisim_dom_eq)
 apply(frule FWbisimulation_base.mbisim_wset_thread_ok2)
 apply(fastforce simp add: FWbisimulation_base.mbisim_def flip_simps)
apply(frule FWbisimulation_base.mbisim_dom_eq)
apply(frule FWbisimulation_base.mbisim_wset_thread_ok2)
apply(fastforce simp add: FWbisimulation_base.mbisim_def flip_simps)
done

lemma mta_bisim_flip [flip_simps]:
  "FWbisimulation_base.mta_bisim (λt. flip (bisim t)) = flip (FWbisimulation_base.mta_bisim bisim)"
by(auto simp add: fun_eq_iff flip_simps FWbisimulation_base.mta_bisim_def)

lemma flip_const [simp]: "flip (λa b. c) = (λa b. c)"
by(rule flip_def)

lemma mbisim_K_flip [flip_simps]:
  "FWbisimulation_base.mbisim (λt. flip (bisim t)) (λx1 x2. c) s1 s2 = 
   FWbisimulation_base.mbisim bisim (λx1 x2. c) s2 s1"
using mbisim_flip[of bisim "λx1 x2. c" s1 s2]
unfolding flip_const . 

context FWbisimulation_base begin

lemma mbisim_actions_ok_bisim_no_join_12:
  assumes mbisim: "mbisim s1 s2"
  and "collect_cond_actions ta1c = {}"
  and "ta_bisim bisim ta1 ta2"
  and "r1.actions_ok s1 t ta1"
  shows "r2.actions_ok s2 t ta2"
using assms mbisim_thrNone_eq[OF mbisim]
by(auto simp add: ta_bisim_def mbisim_def intro: thread_oks_bisim_inv[THEN iffD1] r2.may_join_cond_action_oks)

lemma mbisim_actions_ok_bisim_no_join_21:
  " mbisim s1 s2; collect_cond_actions ta2c = {}; ta_bisim bisim ta1 ta2; r2.actions_ok s2 t ta2 
   r1.actions_ok s1 t ta1"
using FWbisimulation_base.mbisim_actions_ok_bisim_no_join_12[where bisim="λt. flip (bisim t)" and bisim_wait="flip bisim_wait"]
unfolding flip_simps .

lemma mbisim_actions_ok_bisim_no_join:
  " mbisim s1 s2; collect_cond_actions ta1c = {}; ta_bisim bisim ta1 ta2  
   r1.actions_ok s1 t ta1 = r2.actions_ok s2 t ta2"
apply(rule iffI)
 apply(erule (3) mbisim_actions_ok_bisim_no_join_12)
apply(erule mbisim_actions_ok_bisim_no_join_21[where ?ta2.0 = ta2])
  apply(simp add: ta_bisim_def)
apply assumption+
done

end

locale FWbisimulation_base_aux = FWbisimulation_base +
  r1: multithreaded final1 r1 convert_RA +
  r2: multithreaded final2 r2 convert_RA +
  constrains final1 :: "'x1  bool"
  and r1 :: "('l,'t,'x1,'m1,'w, 'o) semantics"
  and final2 :: "'x2  bool"
  and r2 :: "('l,'t,'x2,'m2,'w, 'o) semantics"
  and convert_RA :: "'l released_locks  'o list"
  and bisim :: "'t  ('x1 × 'm1, 'x2 × 'm2) bisim"
  and bisim_wait :: "('x1, 'x2) bisim"
begin

lemma FWbisimulation_base_aux_flip:
  "FWbisimulation_base_aux final2 r2 final1 r1"
by(unfold_locales)

end

lemma FWbisimulation_base_aux_flip_simps [flip_simps]:
  "FWbisimulation_base_aux final2 r2 final1 r1 = FWbisimulation_base_aux final1 r1 final2 r2"
by(blast intro: FWbisimulation_base_aux.FWbisimulation_base_aux_flip)

sublocale FWbisimulation_base_aux < mthr:
  bisimulation_final_base 
    r1.redT
    r2.redT
    mbisim
    mta_bisim
    r1.mfinal
    r2.mfinal
.

declare split_paired_Ex [simp del]

subsection ‹Lifting for delay bisimulations›

locale FWdelay_bisimulation_base =
  FWbisimulation_base _ _ _ r2 convert_RA bisim bisim_wait +
  r1: τmultithreaded final1 r1 convert_RA τmove1 +
  r2: τmultithreaded final2 r2 convert_RA τmove2 
  for r2 :: "('l,'t,'x2,'m2,'w,'o) semantics" ("_  _ -2-_ _" [50,0,0,50] 80)
  and convert_RA :: "'l released_locks  'o list"
  and bisim :: "'t  ('x1 × 'm1, 'x2 × 'm2) bisim" ("_  _/  _" [50, 50, 50] 60)
  and bisim_wait :: "('x1, 'x2) bisim" ("_/ ≈w _" [50, 50] 60)
  and τmove1 :: "('l,'t,'x1,'m1,'w,'o) τmoves"
  and τmove2 :: "('l,'t,'x2,'m2,'w,'o) τmoves"
begin

abbreviation τmred1 :: "('l,'t,'x1,'m1,'w) state  ('l,'t,'x1,'m1,'w) state  bool"
where "τmred1  r1.τmredT"

abbreviation τmred2 :: "('l,'t,'x2,'m2,'w) state  ('l,'t,'x2,'m2,'w) state  bool"
where "τmred2  r2.τmredT"

abbreviation mτmove1 :: "(('l,'t,'x1,'m1,'w) state, 't × ('l,'t,'x1,'m1,'w,'o) thread_action) trsys"
where "mτmove1  r1.mτmove"

abbreviation mτmove2 :: "(('l,'t,'x2,'m2,'w) state, 't × ('l,'t,'x2,'m2,'w,'o) thread_action) trsys"
where "mτmove2  r2.mτmove"

abbreviation τmRed1 :: "('l,'t,'x1,'m1,'w) state  ('l,'t,'x1,'m1,'w) state  bool"
where "τmRed1  τmred1^**"

abbreviation τmRed2 :: "('l,'t,'x2,'m2,'w) state  ('l,'t,'x2,'m2,'w) state  bool"
where "τmRed2  τmred2^**"

abbreviation τmtRed1 :: "('l,'t,'x1,'m1,'w) state  ('l,'t,'x1,'m1,'w) state  bool"
where "τmtRed1  τmred1^++"

abbreviation τmtRed2 :: "('l,'t,'x2,'m2,'w) state  ('l,'t,'x2,'m2,'w) state  bool"
where "τmtRed2  τmred2^++"

lemma bisim_inv_τs1_inv:
  assumes inv: "bisim_inv"
  and bisim: "t  s1  s2"
  and red: "r1.silent_moves t s1 s1'"
  obtains s2' where "t  s1'  s2'"
proof(atomize_elim)
  from red bisim show "s2'. t  s1'  s2'"
    by(induct rule: rtranclp_induct)(fastforce elim: bisim_invD1[OF inv])+
qed

lemma bisim_inv_τs2_inv:
  assumes inv: "bisim_inv"
  and bisim: "t  s1  s2"
  and red: "r2.silent_moves t s2 s2'"
  obtains s1' where "t  s1'  s2'"
proof(atomize_elim)
  from red bisim show "s1'. t  s1'  s2'"
    by(induct rule: rtranclp_induct)(fastforce elim: bisim_invD2[OF inv])+
qed

primrec activate_cond_action1 :: "('l,'t,'x1,'m1,'w) state  ('l,'t,'x2,'m2,'w) state  
                                 't conditional_action  ('l,'t,'x1,'m1,'w) state"
where
  "activate_cond_action1 s1 s2 (Join t) =
   (case thr s1 t of None  s1
            | (x1, ln1)  (case thr s2 t of None  s1
                                     | (x2, ln2)  
  if final2 x2  ln2 = no_wait_locks
  then redT_upd_ε s1 t
                  (SOME x1'. r1.silent_moves t (x1, shr s1) (x1', shr s1)  final1 x1'  
                             t  (x1', shr s1)  (x2, shr s2))
                  (shr s1)
  else s1))"
| "activate_cond_action1 s1 s2 Yield = s1"

primrec activate_cond_actions1 :: "('l,'t,'x1,'m1,'w) state  ('l,'t,'x2,'m2,'w) state
                                   ('t conditional_action) list  ('l,'t,'x1,'m1,'w) state"
where
  "activate_cond_actions1 s1 s2 [] = s1"
| "activate_cond_actions1 s1 s2 (ct # cts) = activate_cond_actions1 (activate_cond_action1 s1 s2 ct) s2 cts"

primrec activate_cond_action2 :: "('l,'t,'x1,'m1,'w) state  ('l,'t,'x2,'m2,'w) state  
                                 't conditional_action  ('l,'t,'x2,'m2,'w) state"
where
 "activate_cond_action2 s1 s2 (Join t) =
   (case thr s2 t of None  s2
            | (x2, ln2)  (case thr s1 t of None  s2
                                     | (x1, ln1)  
  if final1 x1  ln1 = no_wait_locks
  then redT_upd_ε s2 t
                  (SOME x2'. r2.silent_moves t (x2, shr s2) (x2', shr s2)  final2 x2' 
                             t  (x1, shr s1)  (x2', shr s2))
                  (shr s2)
  else s2))"
| "activate_cond_action2 s1 s2 Yield = s2"

primrec activate_cond_actions2 :: "('l,'t,'x1,'m1,'w) state  ('l,'t,'x2,'m2,'w) state 
                                  ('t conditional_action) list  ('l,'t,'x2,'m2,'w) state"
where
  "activate_cond_actions2 s1 s2 [] = s2"
| "activate_cond_actions2 s1 s2 (ct # cts) = activate_cond_actions2 s1 (activate_cond_action2 s1 s2 ct) cts"

end

lemma activate_cond_action1_flip [flip_simps]:
  "FWdelay_bisimulation_base.activate_cond_action1 final2 r2 final1 (λt. flip (bisim t)) τmove2 s2 s1 =
   FWdelay_bisimulation_base.activate_cond_action2 final1 final2 r2 bisim τmove2 s1 s2"
apply(rule ext)
apply(case_tac x)
apply(simp_all only: FWdelay_bisimulation_base.activate_cond_action1.simps 
                     FWdelay_bisimulation_base.activate_cond_action2.simps flip_simps)
done

lemma activate_cond_actions1_flip [flip_simps]:
  "FWdelay_bisimulation_base.activate_cond_actions1 final2 r2 final1 (λt. flip (bisim t)) τmove2 s2 s1 =
   FWdelay_bisimulation_base.activate_cond_actions2 final1 final2 r2 bisim τmove2 s1 s2"
  (is "?lhs = ?rhs")
proof(rule ext)
  fix xs
  show "?lhs xs = ?rhs xs"
    by(induct xs arbitrary: s2)
      (simp_all only: FWdelay_bisimulation_base.activate_cond_actions1.simps
                      FWdelay_bisimulation_base.activate_cond_actions2.simps flip_simps)
qed

lemma activate_cond_action2_flip [flip_simps]:
  "FWdelay_bisimulation_base.activate_cond_action2 final2 final1 r1 (λt. flip (bisim t)) τmove1 s2 s1 =
   FWdelay_bisimulation_base.activate_cond_action1 final1 r1 final2 bisim τmove1 s1 s2"
apply(rule ext)
apply(case_tac x)
apply(simp_all only: FWdelay_bisimulation_base.activate_cond_action1.simps 
                     FWdelay_bisimulation_base.activate_cond_action2.simps flip_simps)
done

lemma activate_cond_actions2_flip [flip_simps]:
  "FWdelay_bisimulation_base.activate_cond_actions2 final2 final1 r1 (λt. flip (bisim t)) τmove1 s2 s1 =
   FWdelay_bisimulation_base.activate_cond_actions1 final1 r1 final2 bisim τmove1 s1 s2"
  (is "?lhs = ?rhs")
proof(rule ext)
  fix xs
  show "?lhs xs = ?rhs xs"
    by(induct xs arbitrary: s1)
      (simp_all only: FWdelay_bisimulation_base.activate_cond_actions1.simps 
                      FWdelay_bisimulation_base.activate_cond_actions2.simps flip_simps)
qed
  
context FWdelay_bisimulation_base begin

lemma shr_activate_cond_action1 [simp]: "shr (activate_cond_action1 s1 s2 ct) = shr s1"
by(cases ct) simp_all

lemma shr_activate_cond_actions1 [simp]: "shr (activate_cond_actions1 s1 s2 cts) = shr s1"
by(induct cts arbitrary: s1) auto

lemma shr_activate_cond_action2 [simp]: "shr (activate_cond_action2 s1 s2 ct) = shr s2"
by(cases ct) simp_all

lemma shr_activate_cond_actions2 [simp]: "shr (activate_cond_actions2 s1 s2 cts) = shr s2"
by(induct cts arbitrary: s2) auto

lemma locks_activate_cond_action1 [simp]: "locks (activate_cond_action1 s1 s2 ct) = locks s1"
by(cases ct) simp_all

lemma locks_activate_cond_actions1 [simp]: "locks (activate_cond_actions1 s1 s2 cts) = locks s1"
by(induct cts arbitrary: s1) auto

lemma locks_activate_cond_action2 [simp]: "locks (activate_cond_action2 s1 s2 ct) = locks s2"
by(cases ct) simp_all

lemma locks_activate_cond_actions2 [simp]: "locks (activate_cond_actions2 s1 s2 cts) = locks s2"
by(induct cts arbitrary: s2) auto

lemma wset_activate_cond_action1 [simp]: "wset (activate_cond_action1 s1 s2 ct) = wset s1"
by(cases ct) simp_all

lemma wset_activate_cond_actions1 [simp]: "wset (activate_cond_actions1 s1 s2 cts) = wset s1"
by(induct cts arbitrary: s1) auto

lemma wset_activate_cond_action2 [simp]: "wset (activate_cond_action2 s1 s2 ct) = wset s2"
by(cases ct) simp_all

lemma wset_activate_cond_actions2 [simp]: "wset (activate_cond_actions2 s1 s2 cts) = wset s2"
by(induct cts arbitrary: s2) auto

lemma interrupts_activate_cond_action1 [simp]: "interrupts (activate_cond_action1 s1 s2 ct) = interrupts s1"
by(cases ct) simp_all

lemma interrupts_activate_cond_actions1 [simp]: "interrupts (activate_cond_actions1 s1 s2 cts) = interrupts s1"
by(induct cts arbitrary: s1) auto

lemma interrupts_activate_cond_action2 [simp]: "interrupts (activate_cond_action2 s1 s2 ct) = interrupts s2"
by(cases ct) simp_all

lemma interrupts_activate_cond_actions2 [simp]: "interrupts (activate_cond_actions2 s1 s2 cts) = interrupts s2"
by(induct cts arbitrary: s2) auto

end

locale FWdelay_bisimulation_lift_aux =
  FWdelay_bisimulation_base _ _ _ _ _ _ _ τmove1 τmove2 +
  r1: τmultithreaded_wf final1 r1 convert_RA τmove1 +
  r2: τmultithreaded_wf final2 r2 convert_RA τmove2 
  for τmove1 :: "('l,'t,'x1,'m1,'w,'o) τmoves"
  and τmove2 :: "('l,'t,'x2,'m2,'w,'o) τmoves"
begin

lemma FWdelay_bisimulation_lift_aux_flip:
  "FWdelay_bisimulation_lift_aux final2 r2 final1 r1 τmove2 τmove1"
by unfold_locales

end

lemma FWdelay_bisimulation_lift_aux_flip_simps [flip_simps]:
  "FWdelay_bisimulation_lift_aux final2 r2 final1 r1 τmove2 τmove1 =
   FWdelay_bisimulation_lift_aux final1 r1 final2 r2 τmove1 τmove2"
by(auto dest: FWdelay_bisimulation_lift_aux.FWdelay_bisimulation_lift_aux_flip simp only: flip_flip)

context FWdelay_bisimulation_lift_aux begin

lemma cond_actions_ok_τmred1_inv:
  assumes red: "τmred1 s1 s1'"
  and ct: "r1.cond_action_ok s1 t ct"
  shows "r1.cond_action_ok s1' t ct"
using ct
proof(cases ct)
  case (Join t')
  show ?thesis using red ct
  proof(cases "thr s1 t'")
    case None with red ct Join show ?thesis
      by(fastforce elim!: r1.mthr.silent_move.cases r1.redT.cases r1.mτmove.cases rtrancl3p_cases 
                  dest: r1.silent_tl split: if_split_asm)
  next
    case (Some a) with red ct Join show ?thesis
      by(fastforce elim!: r1.mthr.silent_move.cases r1.redT.cases r1.mτmove.cases rtrancl3p_cases
                  dest: r1.silent_tl r1.final_no_red split: if_split_asm simp add: redT_updWs_def)
  qed
next
  case Yield thus ?thesis by simp
qed

lemma cond_actions_ok_τmred2_inv:
  " τmred2 s2 s2'; r2.cond_action_ok s2 t ct   r2.cond_action_ok s2' t ct"
using FWdelay_bisimulation_lift_aux.cond_actions_ok_τmred1_inv[OF FWdelay_bisimulation_lift_aux_flip] .

lemma cond_actions_ok_τmRed1_inv:
  " τmRed1 s1 s1'; r1.cond_action_ok s1 t ct   r1.cond_action_ok s1' t ct"
by(induct rule: rtranclp_induct)(blast intro: cond_actions_ok_τmred1_inv)+

lemma cond_actions_ok_τmRed2_inv:
  " τmRed2 s2 s2'; r2.cond_action_ok s2 t ct   r2.cond_action_ok s2' t ct"
by(rule FWdelay_bisimulation_lift_aux.cond_actions_ok_τmRed1_inv[OF FWdelay_bisimulation_lift_aux_flip])

end

locale FWdelay_bisimulation_lift =
  FWdelay_bisimulation_lift_aux +
  constrains final1 :: "'x1  bool"
  and r1 :: "('l, 't, 'x1, 'm1, 'w, 'o) semantics"
  and final2 :: "'x2  bool"
  and r2 :: "('l, 't, 'x2, 'm2, 'w, 'o) semantics"
  and convert_RA :: "'l released_locks  'o list"
  and bisim :: "'t  ('x1 × 'm1, 'x2 × 'm2) bisim"
  and bisim_wait :: "('x1, 'x2) bisim"
  and τmove1 :: "('l, 't, 'x1, 'm1, 'w, 'o) τmoves" 
  and τmove2 :: "('l, 't, 'x2, 'm2, 'w, 'o) τmoves"
  assumes τinv_locale: "τinv (r1 t) (r2 t) (bisim t) (ta_bisim bisim) τmove1 τmove2"

sublocale FWdelay_bisimulation_lift < τinv "r1 t" "r2 t" "bisim t" "ta_bisim bisim" τmove1 τmove2 for t
by(rule τinv_locale)

context FWdelay_bisimulation_lift begin

lemma FWdelay_bisimulation_lift_flip:
  "FWdelay_bisimulation_lift final2 r2 final1 r1 (λt. flip (bisim t)) τmove2 τmove1"
apply(rule FWdelay_bisimulation_lift.intro)
 apply(rule FWdelay_bisimulation_lift_aux_flip)
apply(rule FWdelay_bisimulation_lift_axioms.intro)
apply(unfold flip_simps)
apply(unfold_locales)
done

end

lemma FWdelay_bisimulation_lift_flip_simps [flip_simps]:
  "FWdelay_bisimulation_lift final2 r2 final1 r1 (λt. flip (bisim t)) τmove2 τmove1 =
   FWdelay_bisimulation_lift final1 r1 final2 r2 bisim τmove1 τmove2"
by(auto dest: FWdelay_bisimulation_lift.FWdelay_bisimulation_lift_flip simp only: flip_flip)

context FWdelay_bisimulation_lift begin

lemma τinv_lift: "τinv r1.redT r2.redT mbisim mta_bisim mτmove1 mτmove2"
proof
  fix s1 s2 tl1 s1' tl2 s2'
  assume "s1 ≈m s2" "s1' ≈m s2'" "tl1 ∼T tl2" "r1.redT s1 tl1 s1'" "r2.redT s2 tl2 s2'"
  moreover obtain t ta1 where tl1: "tl1 = (t, ta1)" by(cases tl1)
  moreover obtain t' ta2 where tl2: "tl2 = (t', ta2)" by(cases tl2)
  moreover obtain ls1 ts1 ws1 m1 is1 where s1: "s1 = (ls1, (ts1, m1), ws1, is1)" by(cases s1) fastforce
  moreover obtain ls2 ts2 ws2 m2 is2 where s2: "s2 = (ls2, (ts2, m2), ws2, is2)" by(cases s2) fastforce
  moreover obtain ls1' ts1' ws1' m1' is1' where s1': "s1' = (ls1', (ts1', m1'), ws1', is1')" by(cases s1') fastforce
  moreover obtain ls2' ts2' ws2' m2' is2' where s2': "s2' = (ls2', (ts2', m2'), ws2', is2')" by(cases s2') fastforce
  ultimately have mbisim: "(ls1, (ts1, m1), ws1, is1) ≈m (ls2, (ts2, m2), ws2, is2)"
    and mbisim': "(ls1', (ts1', m1'), ws1', is1') ≈m (ls2', (ts2', m2'), ws2', is2')"
    and mred1: "(ls1, (ts1, m1), ws1, is1) -1-tta1 (ls1', (ts1', m1'), ws1', is1')"
    and mred2: "(ls2, (ts2, m2), ws2, is2) -2-tta2 (ls2', (ts2', m2'), ws2', is2')"
    and tasim: "ta1 ∼m ta2" and tt': "t' = t" by simp_all
  from mbisim have ls: "ls1 = ls2" and ws: "ws1 = ws2" and "is": "is1 = is2"
    and tbisim: "t. tbisim (ws2 t = None) t (ts1 t) m1 (ts2 t) m2" by(simp_all add: mbisim_def)
  from mbisim' have ls': "ls1' = ls2'" and ws': "ws1' = ws2'" and is': "is1' = is2'"
    and tbisim': "t. tbisim (ws2' t = None) t (ts1' t) m1' (ts2' t) m2'" by(simp_all add: mbisim_def)
  from mred1 r1.redT_thread_not_disappear[OF mred1]
  obtain x1 ln1 x1' ln1' where tst1: "ts1 t = (x1, ln1)"
    and tst1': "ts1' t = (x1', ln1')"
    by(fastforce elim!: r1.redT.cases)
  from mred2 r2.redT_thread_not_disappear[OF mred2]
  obtain x2 ln2 x2' ln2' where tst2: "ts2 t = (x2, ln2)"
    and tst2': "ts2' t = (x2', ln2')" by(fastforce elim!: r2.redT.cases)
  from tbisim[of t] tst1 tst2 ws have bisim: "t  (x1, m1)  (x2, m2)"
    and ln: "ln1 = ln2" by(auto simp add: tbisim_def)
  from tbisim'[of t] tst1' tst2' have bisim': "t  (x1', m1')  (x2', m2')"
    and ln': "ln1' = ln2'" by(auto simp add: tbisim_def)
  show "mτmove1 s1 tl1 s1' = mτmove2 s2 tl2 s2'" unfolding s1 s2 s1' s2' tt' tl1 tl2
  proof -
    show "mτmove1 (ls1, (ts1, m1), ws1, is1) (t, ta1) (ls1', (ts1', m1'), ws1', is1') =
          mτmove2 (ls2, (ts2, m2), ws2, is2) (t, ta2) (ls2', (ts2', m2'), ws2', is2')"
      (is "?lhs = ?rhs")
    proof
      assume: ?lhs
      with tst1 tst1' obtain τ1: "τmove1 (x1, m1) ta1 (x1', m1')" 
        and ln1: "ln1 = no_wait_locks" by(fastforce elim!: r1.mτmove.cases)
      from τ1 have "ta1 = ε" by(rule r1.silent_tl)
      with mred1 τ1 tst1 tst1' ln1 have red1: "t  (x1, m1) -1-ta1 (x1', m1')"
        by(auto elim!: r1.redT.cases rtrancl3p_cases)
      from tasim ta1 = ε have [simp]: "ta2 = ε" by(simp)
      with mred2 ln1 ln tst2 tst2' have red2: "t  (x2, m2) -2-ε (x2', m2')"
        by(fastforce elim!: r2.redT.cases rtrancl3p_cases)
      from τ1 τinv[OF bisim red1 red2] bisim' tasim
      have τ2: "τmove2 (x2, m2) ε (x2', m2')" by simp
      with tst2 tst2' ln ln1 show ?rhs by -(rule r2.mτmove.intros, auto)
    next
      assume: ?rhs
      with tst2 tst2' obtain τ2: "τmove2 (x2, m2) ta2 (x2', m2')" 
        and ln2: "ln2 = no_wait_locks" by(fastforce elim!: r2.mτmove.cases)
      from τ2 have "ta2 = ε" by(rule r2.silent_tl)
      with mred2 τ2 tst2 tst2' ln2 have red2: "t  (x2, m2) -2-ta2 (x2', m2')"
        by(auto elim!: r2.redT.cases rtrancl3p_cases)
      from tasim ta2 = ε have [simp]: "ta1 = ε" by simp
      with mred1 ln2 ln tst1 tst1' have red1: "t  (x1, m1) -1-ε (x1', m1')"
        by(fastforce elim!: r1.redT.cases rtrancl3p_cases)
      from τ2 τinv[OF bisim red1 red2] bisim' tasim
      have τ1: "τmove1 (x1, m1) ε (x1', m1')" by auto
      with tst1 tst1' ln ln2 show ?lhs unfolding ta1 = ε
        by-(rule r1.mτmove.intros, auto)
    qed
  qed
qed

end

sublocale FWdelay_bisimulation_lift < mthr: τinv r1.redT r2.redT mbisim mta_bisim mτmove1 mτmove2
by(rule τinv_lift)

locale FWdelay_bisimulation_final_base =
  FWdelay_bisimulation_lift_aux +
  constrains final1 :: "'x1  bool"
  and r1 :: "('l,'t,'x1,'m1,'w, 'o) semantics"
  and final2 :: "'x2  bool"
  and r2 :: "('l,'t,'x2,'m2,'w, 'o) semantics"
  and convert_RA :: "'l released_locks  'o list"
  and bisim :: "'t  ('x1 × 'm1, 'x2 × 'm2) bisim"
  and bisim_wait :: "('x1, 'x2) bisim"
  and τmove1 :: "('l,'t,'x1,'m1,'w, 'o) τmoves"
  and τmove2 :: "('l,'t,'x2,'m2,'w, 'o) τmoves"
  assumes delay_bisim_locale:
  "delay_bisimulation_final_base (r1 t) (r2 t) (bisim t) τmove1 τmove2 (λ(x1, m). final1 x1) (λ(x2, m). final2 x2)"

sublocale FWdelay_bisimulation_final_base <
  delay_bisimulation_final_base "r1 t" "r2 t" "bisim t" "ta_bisim bisim" τmove1 τmove2
                                "λ(x1, m). final1 x1" "λ(x2, m). final2 x2" 
  for t
by(rule delay_bisim_locale)

context FWdelay_bisimulation_final_base begin

lemma FWdelay_bisimulation_final_base_flip:
  "FWdelay_bisimulation_final_base final2 r2 final1 r1 (λt. flip (bisim t)) τmove2 τmove1"
apply(rule FWdelay_bisimulation_final_base.intro)
 apply(rule FWdelay_bisimulation_lift_aux_flip)
apply(rule FWdelay_bisimulation_final_base_axioms.intro)
apply(rule delay_bisimulation_final_base_flip)
done

end

lemma FWdelay_bisimulation_final_base_flip_simps [flip_simps]:
  "FWdelay_bisimulation_final_base final2 r2 final1 r1 (λt. flip (bisim t)) τmove2 τmove1 =
   FWdelay_bisimulation_final_base final1 r1 final2 r2 bisim τmove1 τmove2"
by(auto dest: FWdelay_bisimulation_final_base.FWdelay_bisimulation_final_base_flip simp only: flip_flip)

context FWdelay_bisimulation_final_base begin

lemma cond_actions_ok_bisim_ex_τ1_inv:
  fixes ls ts1 m1 ws "is" ts2 m2 ct
  defines "s1'  activate_cond_action1 (ls, (ts1, m1), ws, is) (ls, (ts2, m2), ws, is) ct"
  assumes mbisim: "t'. t'  t  tbisim (ws t' = None) t' (ts1 t') m1 (ts2 t') m2"
  and ts1t: "ts1 t = Some xln"
  and ts2t: "ts2 t = Some xln'"
  and ct: "r2.cond_action_ok (ls, (ts2, m2), ws, is) t ct"
  shows "τmRed1 (ls, (ts1, m1), ws, is) s1'"
  and "t'. t'  t  tbisim (ws t' = None) t' (thr s1' t') m1 (ts2 t') m2"
  and "r1.cond_action_ok s1' t ct"
  and "thr s1' t = Some xln"
proof -
  have "τmRed1 (ls, (ts1, m1), ws, is) s1' 
        (t'. t'  t  tbisim (ws t' = None) t' (thr s1' t') m1 (ts2 t') m2) 
        r1.cond_action_ok s1' t ct  thr s1' t = xln"
    using ct
  proof(cases ct)
    case (Join t')
    show ?thesis 
    proof(cases "ts1 t'")
      case None
      with mbisim ts1t have "t  t'" by auto
      moreover from None Join have "s1' = (ls, (ts1, m1), ws, is)" by(simp add: s1'_def)
      ultimately show ?thesis using mbisim Join ct None ts1t by(simp add: tbisim_def)
    next
      case (Some xln)
      moreover obtain x1 ln where "xln = (x1, ln)" by(cases xln)
      ultimately have ts1t': "ts1 t' = (x1, ln)" by simp
      from Join ct Some ts2t have tt': "t'  t" by auto
      from mbisim[OF tt'] ts1t' obtain x2 where ts2t': "ts2 t' = (x2, ln)" 
        and bisim: "t'  (x1, m1)  (x2, m2)" by(auto simp add: tbisim_def)
      from ct Join ts2t' have final2: "final2 x2" and ln: "ln = no_wait_locks"
      and wst': "ws t' = None" by simp_all
      let ?x1' = "SOME x. r1.silent_moves t' (x1, m1) (x, m1)  final1 x  t'  (x, m1)  (x2, m2)"
      { from final2_simulation[OF bisim] final2 obtain x1' m1' 
          where "r1.silent_moves t' (x1, m1) (x1', m1')" and "t'  (x1', m1')  (x2, m2)"
          and "final1 x1'" by auto
        moreover hence "m1' = m1" using bisim by(auto dest: r1.red_rtrancl_τ_heapD_inv)
        ultimately have "x. r1.silent_moves t' (x1, m1) (x, m1)  final1 x  t'  (x, m1)  (x2, m2)"
          by blast }
      from someI_ex[OF this] have red1: "r1.silent_moves t' (x1, m1) (?x1', m1)"
        and final1: "final1 ?x1'" and bisim': "t'  (?x1', m1)  (x2, m2)" by blast+
      let ?S1' = "redT_upd_ε (ls, (ts1, m1), ws, is) t' ?x1' m1"
      from r1.silent_moves_into_RedT_τ_inv[where ?s="(ls, (ts1, m1), ws, is)" and t=t', simplified, OF red1]
        bisim ts1t' ln wst'
      have Red1: "τmRed1 (ls, (ts1, m1), ws, is) ?S1'" by auto
      moreover from Join ln ts1t' final1 wst' tt'
      have ct': "r1.cond_action_ok ?S1' t ct" by(auto intro: finfun_ext)
      { fix t''
        assume "t  t''"
        with Join mbisim[OF this[symmetric]] bisim' ts1t' ts2t' wst' s1'_def
        have "tbisim (ws t'' = None) t'' (thr s1' t'') m1 (ts2 t'') m2"
          by(auto simp add: tbisim_def redT_updLns_def o_def finfun_Diag_const2) }
      moreover from Join ts1t' ts2t' final2 ln have "s1' = ?S1'" by(simp add: s1'_def)
      ultimately show ?thesis using Red1 ct' ts1t' tt' ts1t by(auto)
    qed
  next
    case Yield thus ?thesis using mbisim ts1t by(simp add: s1'_def)
  qed
  thus "τmRed1 (ls, (ts1, m1), ws, is) s1'"
    and "t'. t'  t  tbisim (ws t' = None) t' (thr s1' t') m1 (ts2 t') m2"
    and "r1.cond_action_ok s1' t ct"
    and "thr s1' t = xln" by blast+
qed

lemma cond_actions_oks_bisim_ex_τ1_inv:
  fixes ls ts1 m1 ws "is" ts2 m2 cts
  defines "s1'  activate_cond_actions1 (ls, (ts1, m1), ws, is) (ls, (ts2, m2), ws, is) cts"
  assumes tbisim: "t'. t'  t  tbisim (ws t' = None) t' (ts1 t') m1 (ts2 t') m2"
  and ts1t: "ts1 t = Some xln"
  and ts2t: "ts2 t = Some xln'"
  and ct: "r2.cond_action_oks (ls, (ts2, m2), ws, is) t cts"
  shows "τmRed1 (ls, (ts1, m1), ws, is) s1'" 
  and "t'. t'  t  tbisim (ws t' = None) t' (thr s1' t') m1 (ts2 t') m2"
  and "r1.cond_action_oks s1' t cts"
  and "thr s1' t = Some xln"
using tbisim ts1t ct unfolding s1'_def
proof(induct cts arbitrary: ts1)
  case (Cons ct cts)
  note IH1 = ts1. t'. t'  t  tbisim (ws t' = None) t' (ts1 t') m1 (ts2 t') m2; ts1 t = xln;
                    r2.cond_action_oks (ls, (ts2, m2), ws, is) t cts
               τmred1** (ls, (ts1, m1), ws, is) (activate_cond_actions1 (ls, (ts1, m1), ws, is) (ls, (ts2, m2), ws, is) cts)
  note IH2 = t' ts1. t'  t; t'. t'  t  tbisim (ws t' = None) t' (ts1 t') m1 (ts2 t') m2; ts1 t = xln;
                        r2.cond_action_oks (ls, (ts2, m2), ws, is) t cts
            tbisim (ws t' = None) t' (thr (activate_cond_actions1 (ls, (ts1, m1), ws, is) (ls, (ts2, m2), ws, is) cts) t') m1 (ts2 t') m2
  note IH3 = ts1. t'. t'  t  tbisim (ws t' = None) t' (ts1 t') m1 (ts2 t') m2; ts1 t = xln;
                     r2.cond_action_oks (ls, (ts2, m2), ws, is) t cts
               r1.cond_action_oks (activate_cond_actions1 (ls, (ts1, m1), ws, is) (ls, (ts2, m2), ws, is) cts) t cts
  note IH4 = ts1. t'. t'  t  tbisim (ws t' = None) t' (ts1 t') m1 (ts2 t') m2; ts1 t = xln;
                     r2.cond_action_oks (ls, (ts2, m2), ws, is) t cts
               thr (activate_cond_actions1 (ls, (ts1, m1), ws, is) (ls, (ts2, m2), ws, is) cts) t = xln
  { fix ts1
    assume tbisim: "t'. t'  t  tbisim (ws t' = None) t' (ts1 t') m1 (ts2 t') m2"
      and ts1t: "ts1 t = xln"
      and ct: "r2.cond_action_oks (ls, (ts2, m2), ws, is) t (ct # cts)"
    from ct have 1: "r2.cond_action_ok (ls, (ts2, m2), ws, is) t ct"
      and 2: "r2.cond_action_oks (ls, (ts2, m2), ws, is) t cts" by auto
    let ?s1' = "activate_cond_action1 (ls, (ts1, m1), ws, is) (ls, (ts2, m2), ws, is) ct"
    from cond_actions_ok_bisim_ex_τ1_inv[OF tbisim, OF _ ts1t ts2t 1]
    have tbisim': "t'. t'  t  tbisim (ws t' = None) t' (thr ?s1' t') m1 (ts2 t') m2"
      and red: "τmRed1 (ls, (ts1, m1), ws, is) ?s1'" and ct': "r1.cond_action_ok ?s1' t ct" 
      and ts1't: "thr ?s1' t = xln" by blast+
    let ?s1'' = "activate_cond_actions1 ?s1' (ls, (ts2, m2), ws, is) cts"
    have "locks ?s1' = ls" "shr ?s1' = m1" "wset ?s1' = ws" "interrupts ?s1' = is" by simp_all
    hence s1': "(ls, (thr ?s1', m1), ws, is) = ?s1'" by(cases "?s1'") auto
    from IH1[OF tbisim', OF _ ts1't 2] s1' have red': "τmRed1 ?s1' ?s1''" by simp
    with red show "τmRed1 (ls, (ts1, m1), ws, is) (activate_cond_actions1 (ls, (ts1, m1), ws, is) (ls, (ts2, m2), ws, is) (ct # cts))"
      by auto
    { fix t'
      assume t't: "t'  t"
      from IH2[OF t't tbisim', OF _ ts1't 2] s1'
      show "tbisim (ws t' = None) t' (thr (activate_cond_actions1 (ls, (ts1, m1), ws, is) (ls, (ts2, m2), ws, is) (ct # cts)) t') m1 (ts2 t') m2"
        by auto }
    from red' ct' have "r1.cond_action_ok ?s1'' t ct" by(rule cond_actions_ok_τmRed1_inv)
    with IH3[OF tbisim', OF _ ts1't 2] s1'
    show "r1.cond_action_oks (activate_cond_actions1 (ls, (ts1, m1), ws, is) (ls, (ts2, m2), ws, is) (ct # cts)) t (ct # cts)"
      by auto
    from ts1't IH4[OF tbisim', OF _ ts1't 2] s1'
    show "thr (activate_cond_actions1 (ls, (ts1, m1), ws, is) (ls, (ts2, m2), ws, is) (ct # cts)) t = xln" by auto }
qed(auto)

lemma cond_actions_ok_bisim_ex_τ2_inv:
  fixes ls ts1 m1 "is" ws ts2 m2 ct
  defines "s2'  activate_cond_action2 (ls, (ts1, m1), ws, is) (ls, (ts2, m2), ws, is) ct"
  assumes mbisim: "t'. t'  t  tbisim (ws t' = None) t' (ts1 t') m1 (ts2 t') m2"
  and ts1t: "ts1 t = Some xln"
  and ts2t: "ts2 t = Some xln'"
  and ct: "r1.cond_action_ok (ls, (ts1, m1), ws, is) t ct"
  shows "τmRed2 (ls, (ts2, m2), ws, is) s2'"
  and "t'. t'  t  tbisim (ws t' = None) t' (ts1 t') m1 (thr s2' t') m2"
  and "r2.cond_action_ok s2' t ct"
  and "thr s2' t = Some xln'"
unfolding s2'_def
by(blast intro: FWdelay_bisimulation_final_base.cond_actions_ok_bisim_ex_τ1_inv[OF FWdelay_bisimulation_final_base_flip, where bisim_wait = "flip bisim_wait", unfolded flip_simps, OF mbisim _ _ ct, OF _ ts2t ts1t])+

lemma cond_actions_oks_bisim_ex_τ2_inv:
  fixes ls ts1 m1 ws "is" ts2 m2 cts
  defines "s2'  activate_cond_actions2 (ls, (ts1, m1), ws, is) (ls, (ts2, m2), ws, is) cts"
  assumes tbisim: "t'. t'  t  tbisim (ws t' = None) t' (ts1 t') m1 (ts2 t') m2"
  and ts1t: "ts1 t = Some xln"
  and ts2t: "ts2 t = Some xln'"
  and ct: "r1.cond_action_oks (ls, (ts1, m1), ws, is) t cts"
  shows "τmRed2 (ls, (ts2, m2), ws, is) s2'"
  and "t'. t'  t  tbisim (ws t' = None) t' (ts1 t') m1 (thr s2' t') m2"
  and "r2.cond_action_oks s2' t cts"
  and "thr s2' t = Some xln'"
unfolding s2'_def
by(blast intro: FWdelay_bisimulation_final_base.cond_actions_oks_bisim_ex_τ1_inv[OF FWdelay_bisimulation_final_base_flip, where bisim_wait = "flip bisim_wait", unfolded flip_simps, OF tbisim _ _ ct, OF _ ts2t ts1t])+

lemma mfinal1_inv_simulation:
  assumes "s1 ≈m s2" 
  shows "s2'. r2.mthr.silent_moves s2 s2'  s1 ≈m s2'  r1.final_threads s1  r2.final_threads s2'  shr s2' = shr s2"
proof -
  from s1 ≈m s2 have "finite (dom (thr s1))" by(auto dest: mbisim_finite1)
  moreover have "r1.final_threads s1  dom (thr s1)" by(auto simp add: r1.final_thread_def)
  ultimately have "finite (r1.final_threads s1)" by(blast intro: finite_subset)
  thus ?thesis using s1 ≈m s2
  proof(induct A"r1.final_threads s1" arbitrary: s1 s2 rule: finite_induct)
    case empty
    from {} = r1.final_threads s1[symmetric] have "t. ¬ r1.final_thread s1 t" by(auto)
    with s1 ≈m s2 show ?case by blast
  next
    case (insert t A)
    define s1' where "s1' = (locks s1, ((thr s1)(t := None), shr s1), wset s1, interrupts s1)"
    define s2' where "s2' = (locks s2, ((thr s2)(t := None), shr s2), wset s2, interrupts s2)"
    from t  A ‹insert t A = r1.final_threads s1 have "A = r1.final_threads s1'"
      unfolding s1'_def by(auto simp add: r1.final_thread_def r1.final_threads_def)
    moreover from ‹insert t A = r1.final_threads s1 have "r1.final_thread s1 t" by auto
    hence "wset s1 t = None" by(auto simp add: r1.final_thread_def)
    with s1 ≈m s2 have "s1' ≈m s2'" unfolding s1'_def s2'_def
      by(auto simp add: mbisim_def intro: tbisim_NoneI intro!: wset_thread_okI dest: wset_thread_okD split: if_split_asm)
    ultimately have "s2''. r2.mthr.silent_moves s2' s2''  s1' ≈m s2''  r1.final_threads s1'  r2.final_threads s2''  shr s2'' = shr s2'" by(rule insert)
    then obtain s2'' where reds: "r2.mthr.silent_moves s2' s2''" 
      and "s1' ≈m s2''" and fin: "t. r1.final_thread s1' t  r2.final_thread s2'' t" and "shr s2'' = shr s2'" by blast
    have "thr s2' t = None" unfolding s2'_def by simp
    with ‹r2.mthr.silent_moves s2' s2''
    have "r2.mthr.silent_moves (locks s2', (thr s2'(t  the (thr s2 t)), shr s2'), wset s2', interrupts s2')
      (locks s2'', (thr s2''(t  the (thr s2 t)), shr s2''), wset s2'', interrupts s2'')"
      by(rule r2.τmRedT_add_thread_inv)
    also let ?s2'' = "(locks s2, (thr s2''(t  the (thr s2 t)), shr s2), wset s2, interrupts s2)"
    from ‹shr s2'' = shr s2' s1' ≈m s2'' s1 ≈m s2
    have "(locks s2'', (thr s2''(t  the (thr s2 t)), shr s2''), wset s2'', interrupts s2'') = ?s2''"
      unfolding s2'_def s1'_def by(simp add: mbisim_def)
    also (back_subst) from s1 ≈m s2 have "dom (thr s1) = dom (thr s2)" by(rule mbisim_dom_eq)
    with ‹r1.final_thread s1 t have "t  dom (thr s2)" by(auto simp add: r1.final_thread_def)
    then obtain x2 ln where tst2: "thr s2 t = (x2, ln)" by auto
    hence "(locks s2', (thr s2'(t  the (thr s2 t)), shr s2'), wset s2', interrupts s2') = s2"
      unfolding s2'_def by(cases s2)(auto intro!: ext)
    also from s1 ≈m s2 tst2 obtain x1
      where tst1: "thr s1 t = (x1, ln)"
      and bisim: "t  (x1, shr s1)  (x2, shr s2)" by(auto dest: mbisim_thrD2)
    from ‹shr s2'' = shr s2' have "shr ?s2'' = shr s2" by(simp add: s2'_def)
    from ‹r1.final_thread s1 t tst1
    have final: "final1 x1" "ln = no_wait_locks" "wset s1 t = None" by(auto simp add: r1.final_thread_def)
    with final1_simulation[OF bisim] ‹shr ?s2'' = shr s2 obtain x2' m2'
      where red: "r2.silent_moves t (x2, shr ?s2'') (x2', m2')"
      and bisim': "t  (x1, shr s1)  (x2', m2')" and "final2 x2'" by auto
    from ‹wset s1 t = None› s1 ≈m s2 have "wset s2 t = None" by(simp add: mbisim_def) 
    with bisim r2.silent_moves_into_RedT_τ_inv[OF red] tst2 ln = no_wait_locks›
    have "r2.mthr.silent_moves ?s2'' (redT_upd_ε ?s2'' t x2' m2')" unfolding s2'_def by auto
    also (rtranclp_trans)
    from bisim r2.red_rtrancl_τ_heapD_inv[OF red] have "m2' = shr s2" by auto
    hence "s1 ≈m (redT_upd_ε ?s2'' t x2' m2')"
      using s1' ≈m s2'' s1 ≈m s2 tst1 tst2 ‹shr ?s2'' = shr s2 bisim' ‹shr s2'' = shr s2' ‹wset s2 t = None›
      unfolding s1'_def s2'_def by(auto simp add: mbisim_def redT_updLns_def split: if_split_asm intro: tbisim_SomeI)
    moreover { 
      fix t'
      assume "r1.final_thread s1 t'"
      with fin[of t'] final2 x2' tst2 ln = no_wait_locks› ‹wset s2 t = None› s1' ≈m s2'' s1 ≈m s2
      have "r2.final_thread (redT_upd_ε ?s2'' t x2' m2') t'" unfolding s1'_def
        by(fastforce split: if_split_asm simp add: r2.final_thread_def r1.final_thread_def redT_updLns_def finfun_Diag_const2 o_def mbisim_def)
    }
    moreover have "shr (redT_upd_ε ?s2'' t x2' m2') = shr s2" using m2' = shr s2 by simp
    ultimately show ?case by blast
  qed
qed

lemma mfinal2_inv_simulation:
  "s1 ≈m s2  s1'. r1.mthr.silent_moves s1 s1'  s1' ≈m s2  r2.final_threads s2  r1.final_threads s1'  shr s1' = shr s1"
using FWdelay_bisimulation_final_base.mfinal1_inv_simulation[OF FWdelay_bisimulation_final_base_flip, where bisim_wait="flip bisim_wait"]
by(unfold flip_simps)

lemma mfinal1_simulation:
  assumes "s1 ≈m s2" and "r1.mfinal s1"
  shows "s2'. r2.mthr.silent_moves s2 s2'  s1 ≈m s2'  r2.mfinal s2'  shr s2' = shr s2"
proof -
  from mfinal1_inv_simulation[OF s1 ≈m s2]
  obtain s2' where 1: "r2.mthr.silent_moves s2 s2'" "s1 ≈m s2'" "shr s2' = shr s2"
    and fin: "t. r1.final_thread s1 t  r2.final_thread s2' t" by blast
  have "r2.mfinal s2'"
  proof(rule r2.mfinalI)
    fix t x2 ln
    assume "thr s2' t = (x2, ln)"
    with s1 ≈m s2' obtain x1 where "thr s1 t = (x1, ln)" "t  (x1, shr s1)  (x2, shr s2')"
      by(auto dest: mbisim_thrD2)
    from ‹thr s1 t = (x1, ln) ‹r1.mfinal s1 have "r1.final_thread s1 t"
      by(auto elim!: r1.mfinalE simp add: r1.final_thread_def)
    hence "r2.final_thread s2' t" by(rule fin)
    thus "final2 x2  ln = no_wait_locks  wset s2' t = None"
      using ‹thr s2' t = (x2, ln) by(auto simp add: r2.final_thread_def)
  qed
  with 1 show ?thesis by blast
qed
    
lemma mfinal2_simulation:
  " s1 ≈m s2; r2.mfinal s2 
   s1'. r1.mthr.silent_moves s1 s1'  s1' ≈m s2  r1.mfinal s1'  shr s1' = shr s1"
using FWdelay_bisimulation_final_base.mfinal1_simulation[OF FWdelay_bisimulation_final_base_flip, where bisim_wait = "flip bisim_wait"]
by(unfold flip_simps)

end

locale FWdelay_bisimulation_obs =
  FWdelay_bisimulation_final_base _ _ _ _ _ _ _ τmove1 τmove2
  for τmove1 :: "('l,'t,'x1,'m1,'w, 'o) τmoves"
  and τmove2 :: "('l,'t,'x2,'m2,'w, 'o) τmoves" +
  assumes delay_bisimulation_obs_locale: "delay_bisimulation_obs (r1 t) (r2 t) (bisim t) (ta_bisim bisim) τmove1 τmove2"
  and bisim_inv_red_other:
   " t'  (x, m1)  (xx, m2); t  (x1, m1)  (x2, m2); 
      r1.silent_moves t (x1, m1) (x1', m1);
      t  (x1', m1) -1-ta1 (x1'', m1'); ¬ τmove1 (x1', m1) ta1 (x1'', m1');
      r2.silent_moves t (x2, m2) (x2', m2);
      t  (x2', m2) -2-ta2 (x2'', m2'); ¬ τmove2 (x2', m2) ta2 (x2'', m2');
      t  (x1'', m1')  (x2'', m2'); ta_bisim bisim ta1 ta2 
    t'  (x, m1')  (xx, m2')"
  and bisim_waitI:
   " t  (x1, m1)  (x2, m2); r1.silent_moves t (x1, m1) (x1', m1);
      t  (x1', m1) -1-ta1 (x1'', m1'); ¬ τmove1 (x1', m1) ta1 (x1'', m1');
      r2.silent_moves t (x2, m2) (x2', m2);
      t  (x2', m2) -2-ta2 (x2'', m2'); ¬ τmove2 (x2', m2) ta2 (x2'', m2');
      t  (x1'', m1')  (x2'', m2'); ta_bisim bisim ta1 ta2;
      Suspend w  set ta1w; Suspend w  set ta2w 
    x1'' ≈w x2''"
  and simulation_Wakeup1:
    " t  (x1, m1)  (x2, m2); x1 ≈w x2; t  (x1, m1) -1-ta1 (x1', m1'); Notified  set ta1w  WokenUp  set ta1w 
     ta2 x2' m2'. t  (x2, m2) -2-ta2 (x2', m2')  t  (x1', m1')  (x2', m2')  ta_bisim bisim ta1 ta2"
  and simulation_Wakeup2:
    " t  (x1, m1)  (x2, m2); x1 ≈w x2; t  (x2, m2) -2-ta2 (x2', m2'); Notified  set ta2w  WokenUp  set ta2w 
     ta1 x1' m1'. t  (x1, m1) -1-ta1 (x1', m1')  t  (x1', m1')  (x2', m2')  ta_bisim bisim ta1 ta2"
  and ex_final1_conv_ex_final2:
    "(x1. final1 x1)  (x2. final2 x2)"

sublocale FWdelay_bisimulation_obs <
  delay_bisimulation_obs "r1 t" "r2 t" "bisim t" "ta_bisim bisim" τmove1 τmove2 for t
by(rule delay_bisimulation_obs_locale)

context FWdelay_bisimulation_obs begin

lemma FWdelay_bisimulation_obs_flip:
  "FWdelay_bisimulation_obs final2 r2 final1 r1 (λt. flip (bisim t)) (flip bisim_wait) τmove2 τmove1"
apply(rule FWdelay_bisimulation_obs.intro)
 apply(rule FWdelay_bisimulation_final_base_flip)
apply(rule FWdelay_bisimulation_obs_axioms.intro)
     apply(unfold flip_simps)
     apply(rule delay_bisimulation_obs_axioms)
    apply(erule (9) bisim_inv_red_other)
   apply(erule (10) bisim_waitI)
  apply(erule (3) simulation_Wakeup2)
 apply(erule (3) simulation_Wakeup1)
apply(rule ex_final1_conv_ex_final2[symmetric])
done

end

lemma FWdelay_bisimulation_obs_flip_simps [flip_simps]:
  "FWdelay_bisimulation_obs final2 r2 final1 r1 (λt. flip (bisim t)) (flip bisim_wait) τmove2 τmove1 = 
   FWdelay_bisimulation_obs final1 r1 final2 r2 bisim bisim_wait τmove1 τmove2"
by(auto dest: FWdelay_bisimulation_obs.FWdelay_bisimulation_obs_flip simp only: flip_flip)

context FWdelay_bisimulation_obs begin

lemma mbisim_redT_upd:
  fixes s1 t ta1 x1' m1' s2 ta2 x2' m2' ln
  assumes s1': "redT_upd s1 t ta1 x1' m1' s1'"
  and s2': "redT_upd s2 t ta2 x2' m2' s2'"
  and [simp]: "wset s1 = wset s2" "locks s1 = locks s2" 
  and wset: "wset s1' = wset s2'"
  and interrupts: "interrupts s1' = interrupts s2'"
  and fin1: "finite (dom (thr s1))"
  and wsts: "wset_thread_ok (wset s1) (thr s1)"
  and tst: "thr s1 t = (x1, ln)"
  and tst': "thr s2 t = (x2, ln)"
  and aoe1: "r1.actions_ok s1 t ta1"
  and aoe2: "r2.actions_ok s2 t ta2"
  and tasim: "ta_bisim bisim ta1 ta2"
  and bisim': "t  (x1', m1')  (x2', m2')"
  and bisimw: "wset s1' t = None  x1' ≈w x2'"
  and τred1: "r1.silent_moves t (x1'', shr s1) (x1, shr s1)"
  and red1: "t  (x1, shr s1) -1-ta1 (x1', m1')"
  and τred2: "r2.silent_moves t (x2'', shr s2) (x2, shr s2)"
  and red2: "t  (x2, shr s2) -2-ta2 (x2', m2')"
  and bisim: "t  (x1'', shr s1)  (x2'', shr s2)"
  and τ1: "¬ τmove1 (x1, shr s1) ta1 (x1', m1')"
  and τ2: "¬ τmove2 (x2, shr s2) ta2 (x2', m2')"
  and tbisim: "t'. t  t'  tbisim (wset s1 t' = None) t' (thr s1 t') (shr s1) (thr s2 t') (shr s2)"
  shows "s1' ≈m s2'"
proof(rule mbisimI)
  from fin1 s1' show "finite (dom (thr s1'))"
    by(auto simp add: redT_updTs_finite_dom_inv)
next
  from tasim s1' s2' show "locks s1' = locks s2'"
    by(auto simp add: redT_updLs_def o_def ta_bisim_def)
next
  from wset show "wset s1' = wset s2'" .
next
  from interrupts show "interrupts s1' = interrupts s2'" .
next
  from wsts s1' s2' wset show "wset_thread_ok (wset s1') (thr s1')"
    by(fastforce intro!: wset_thread_okI split: if_split_asm dest: redT_updTs_None wset_thread_okD redT_updWs_None_implies_None)
next
  fix T
  assume "thr s1' T = None"
  moreover with tst s1' have [simp]: "t  T" by auto
  from tbisim[OF this] have "(thr s1 T = None) = (thr s2 T = None)"
    by(auto simp add: tbisim_def)
  hence "(redT_updTs (thr s1) ta1t T = None) = (redT_updTs (thr s2) ta2t T = None)"
    using tasim by -(rule redT_updTs_nta_bisim_inv, simp_all add: ta_bisim_def)
  ultimately show "thr s2' T = None" using s2' s1' by(auto split: if_split_asm)
next
  fix T X1 LN
  assume tsT: "thr s1' T = (X1, LN)"
  show "x2. thr s2' T = (x2, LN)  T  (X1, shr s1')  (x2, shr s2')  (wset s2' T = None  X1 ≈w x2)"
  proof(cases "thr s1 T")
    case None
    with tst have "t  T" by auto
    with tbisim[OF this] None have tsT': "thr s2 T = None" by(simp add: tbisim_def)
    from None t  T tsT aoe1 s1' obtain M1
      where ntset: "NewThread T X1 M1  set ta1t" and [simp]: "LN = no_wait_locks"
      by(auto dest!: redT_updTs_new_thread)
    from ntset obtain tas1 tas1' where "ta1t = tas1 @ NewThread T X1 M1 # tas1'"
      by(auto simp add: in_set_conv_decomp)
    with tasim obtain tas2 X2 M2 tas2' where "ta2t = tas2 @ NewThread T X2 M2 # tas2'"
      "length tas2 = length tas2" "length tas1' = length tas2'" and Bisim: "T  (X1, M1)  (X2, M2)"
      by(auto simp add: list_all2_append1 list_all2_Cons1 ta_bisim_def)
    hence ntset': "NewThread T X2 M2  set ta2t" by auto
    with tsT' t  T aoe2 s2' have "thr s2' T = (X2, no_wait_locks)"
      by(auto intro: redT_updTs_new_thread_ts)
    moreover from ntset' red2 have "m2' = M2" by(auto dest: r2.new_thread_memory)
    moreover from ntset red1 have "m1' = M1"
      by(auto dest: r1.new_thread_memory)
    moreover from wsts None have "wset s1 T = None" by(rule wset_thread_okD)
    ultimately show ?thesis using Bisim t  T s1' s2'
      by(auto simp add: redT_updWs_None_implies_None)
  next
    case (Some a)
    show ?thesis
    proof(cases "t = T")
      case True
      with tst tsT s1' have [simp]: "X1 = x1'" "LN = redT_updLns (locks s1) t ln ta1l" by(auto)
      show ?thesis using True bisim' bisimw tasim tst tst' s1' s2' wset
        by(auto simp add: redT_updLns_def ta_bisim_def)
    next
      case False
      with Some aoe1 tsT s1' have "thr s1 T = (X1, LN)" by(auto dest: redT_updTs_Some)
      with tbisim[OF False] obtain X2 
        where tsT': "thr s2 T = (X2, LN)" and Bisim: "T  (X1, shr s1)  (X2, shr s2)"
        and bisimw: "wset s1 T = None  X1 ≈w X2" by(auto simp add: tbisim_def)
      with aoe2 False s2' have tsT': "thr s2' T = (X2, LN)" by(auto simp add: redT_updTs_Some)
      moreover from Bisim bisim τred1 red1 τ1 τred2 red2 τ2 bisim' tasim
      have "T  (X1, m1')  (X2, m2')" by(rule bisim_inv_red_other)
      ultimately show ?thesis using False bisimw s1' s2'
        by(auto simp add: redT_updWs_None_implies_None)
    qed
  qed
qed

theorem mbisim_simulation1:
  assumes mbisim: "mbisim s1 s2" and "¬ mτmove1 s1 tl1 s1'" "r1.redT s1 tl1 s1'"
  shows "s2' s2'' tl2. r2.mthr.silent_moves s2 s2'  r2.redT s2' tl2 s2'' 
                        ¬ mτmove2 s2' tl2 s2''  mbisim s1' s2''  mta_bisim tl1 tl2"
proof -
  from assms obtain t ta1 where tl1 [simp]: "tl1 = (t, ta1)" and redT: "s1 -1-tta1 s1'"
    and: "¬ mτmove1 s1 (t, ta1) s1'" by(cases tl1) fastforce
  obtain ls1 ts1 m1 ws1 is1 where [simp]: "s1 = (ls1, (ts1, m1), ws1, is1)" by(cases s1) fastforce
  obtain ls1' ts1' m1' ws1' is1' where [simp]: "s1' = (ls1', (ts1', m1'), ws1', is1')" by(cases s1') fastforce
  obtain ls2 ts2 m2 ws2 is2 where [simp]: "s2 = (ls2, (ts2, m2), ws2, is2)" by(cases s2) fastforce
  from mbisim have [simp]: "ls2 = ls1" "ws2 = ws1" "is2 = is1" "finite (dom ts1)" by(auto simp add: mbisim_def)
  from redT show ?thesis
  proof cases
    case (redT_normal x1 x1' M1')
    hence red: "t  (x1, m1) -1-ta1 (x1', M1')" 
      and tst: "ts1 t = (x1, no_wait_locks)"
      and aoe: "r1.actions_ok s1 t ta1"
      and s1': "redT_upd s1 t ta1 x1' M1' s1'" by auto
    from mbisim tst obtain x2 where tst': "ts2 t = (x2, no_wait_locks)"
      and bisim: "t  (x1, m1)  (x2, m2)" by(auto dest: mbisim_thrD1)
    fromhave τ: "¬ τmove1 (x1, m1) ta1 (x1', M1')"
    proof(rule contrapos_nn)
      assume τ: "τmove1 (x1, m1) ta1 (x1', M1')"
      moreover hence [simp]: "ta1 = ε" by(rule r1.silent_tl)
      moreover have [simp]: "M1' = m1" by(rule r1.τmove_heap[OF red τ, symmetric])
      ultimately show "mτmove1 s1 (t, ta1) s1'" using s1' tst s1'
        by(auto simp add: redT_updLs_def o_def intro: r1.mτmove.intros elim: rtrancl3p_cases)
    qed
    show ?thesis
    proof(cases "ws1 t")
      case None
      note wst = this
      from simulation1[OF bisim red τ] obtain x2' M2' x2'' M2'' ta2
        where red21: "r2.silent_moves t (x2, m2) (x2', M2')"
        and red22: "t  (x2', M2') -2-ta2 (x2'', M2'')" and τ2: "¬ τmove2 (x2', M2') ta2 (x2'', M2'')"
        and bisim': "t  (x1', M1')  (x2'', M2'')"
        and tasim: "ta_bisim bisim ta1 ta2" by auto
      let ?s2' = "redT_upd_ε s2 t x2' M2'"
      let ?S2' = "activate_cond_actions2 s1 ?s2' ta2c"
      let ?s2'' = "(redT_updLs (locks ?S2') t ta2l, ((redT_updTs (thr ?S2') ta2t)(t  (x2'', redT_updLns (locks ?S2') t (snd (the (thr ?S2' t))) ta2l)), M2''), wset s1', interrupts s1')"
      from red21 tst' wst bisim have "τmRed2 s2 ?s2'"
        by -(rule r2.silent_moves_into_RedT_τ_inv, auto)
      moreover from red21 bisim have [simp]: "M2' = m2" by(auto dest: r2.red_rtrancl_τ_heapD_inv)
      from tasim have [simp]: " ta1l =  ta2l" " ta1w =  ta2w" " ta1c =  ta2c" " ta1i =  ta2i"
        and nta: "list_all2 (nta_bisim bisim)  ta1t  ta2t" by(auto simp add: ta_bisim_def)
      from mbisim have tbisim: "t. tbisim (ws1 t = None) t (ts1 t) m1 (ts2 t) m2" by(simp add: mbisim_def)
      hence tbisim': "t'. t'  t  tbisim (ws1 t' = None) t' (ts1 t') m1 (thr ?s2' t') m2" by(auto)
      from aoe have cao1: "r1.cond_action_oks (ls1, (ts1, m1), ws1, is1) t ta2c" by auto
      from tst' have "thr ?s2' t = (x2', no_wait_locks)" by(auto simp add: redT_updLns_def o_def finfun_Diag_const2)
      from cond_actions_oks_bisim_ex_τ2_inv[OF tbisim', OF _ tst this cao1]
      have red21': "τmRed2 ?s2' ?S2'" and tbisim'': "t'. t'  t  tbisim (ws1 t' = None) t' (ts1 t') m1 (thr ?S2' t') m2"
        and cao2: "r2.cond_action_oks ?S2' t ta2c" and tst'': "thr ?S2' t = (x2', no_wait_locks)"
        by(auto simp del: fun_upd_apply)
      note red21' also (rtranclp_trans)
      from tbisim'' tst'' tst have "t'. ts1 t' = None  thr ?S2' t' = None" by(force simp add: tbisim_def)
      from aoe thread_oks_bisim_inv[OF this nta] have "thread_oks (thr ?S2') ta2t" by simp
      with cao2 aoe have aoe': "r2.actions_ok ?S2' t ta2" by auto
      with red22 tst'' s1' have "?S2' -2-tta2 ?s2''"
        by -(rule r2.redT.redT_normal, auto)
      moreover
      from τ2 have "¬ mτmove2 ?S2' (t, ta2) ?s2''"
      proof(rule contrapos_nn)
        assume: "mτmove2 ?S2' (t, ta2) ?s2''"
        thus "τmove2 (x2', M2') ta2 (x2'', M2'')" using tst'' tst'
          by cases auto
      qed
      moreover
      { 
        note s1'
        moreover have "redT_upd ?S2' t ta2 x2'' M2'' ?s2''" using s1' by auto
        moreover have "wset s1 = wset ?S2'" "locks s1 = locks ?S2'" by simp_all
        moreover have "wset s1' = wset ?s2''" by simp
        moreover have "interrupts s1' = interrupts ?s2''" by simp
        moreover have "finite (dom (thr s1))" by simp
        moreover from mbisim have "wset_thread_ok (wset s1) (thr s1)" by(simp add: mbisim_def) 
        moreover from tst have "thr s1 t = (x1, no_wait_locks)" by simp
        moreover note tst'' aoe aoe' tasim bisim'
        moreover have "wset s1' t = None  x1' ≈w x2''"
        proof(cases "wset s1' t")
          case None thus ?thesis ..
        next
          case (Some w)
          with wst s1' obtain w' where Suspend1: "Suspend w'  set ta1w"
            by(auto dest: redT_updWs_None_SomeD)
          with tasim have Suspend2: "Suspend w'  set ta2w" by(simp add: ta_bisim_def)
          from bisim_waitI[OF bisim rtranclp.rtrancl_refl red τ _ _ _ bisim' tasim Suspend1 this, of x2'] red21 red22 τ2
          have "x1' ≈w x2''" by auto
          thus ?thesis ..
        qed
        moreover note rtranclp.rtrancl_refl
        moreover from red have "t  (x1, shr s1) -1-ta1 (x1', M1')" by simp
        moreover from red21 have "r2.silent_moves t (x2, shr ?S2') (x2', shr ?S2')" by simp
        moreover from red22 have "t  (x2', shr ?S2') -2-ta2 (x2'', M2'')" by simp
        moreover from bisim have "t  (x1, shr s1)  (x2, shr ?S2')" by simp
        moreover from τ have "¬ τmove1 (x1, shr s1) ta1 (x1', M1')" by simp
        moreover from τ2 have "¬ τmove2 (x2', shr ?S2') ta2 (x2'', M2'')" by simp
        moreover from tbisim'' 
        have "t'. t  t'  tbisim (wset s1 t' = None) t' (thr s1 t') (shr s1) (thr ?S2' t') (shr ?S2')" 
          by simp
        ultimately have "mbisim s1' ?s2''" by(rule mbisim_redT_upd)
        }
      ultimately show ?thesis using tasim unfolding tl1 s1' by fastforce
    next
      case (Some w)
      with mbisim tst tst' have "x1 ≈w x2"
        by(auto dest: mbisim_thrD1)
      from aoe Some have wakeup: "Notified  set ta1w  WokenUp  set ta1w"
        by(auto simp add: wset_actions_ok_def split: if_split_asm)
      from simulation_Wakeup1[OF bisim x1 ≈w x2 red this]
      obtain ta2 x2' m2' where red2: "t  (x2, m2) -2-ta2 (x2', m2')"
        and bisim': "t  (x1', M1')  (x2', m2')"
        and tasim: "ta1 ∼m ta2" by auto

      let ?S2' = "activate_cond_actions2 s1 s2 ta2c"

      let ?s2' = "(redT_updLs (locks ?S2') t ta2l, ((redT_updTs (thr ?S2') ta2t)(t  (x2', redT_updLns (locks ?S2') t (snd (the (thr ?S2' t))) ta2l)), m2'), wset s1', interrupts s1')"

      from tasim have [simp]: " ta1l =  ta2l" " ta1w =  ta2w" " ta1c =  ta2c" " ta1i =  ta2i"
        and nta: "list_all2 (nta_bisim bisim)  ta1t  ta2t" by(auto simp add: ta_bisim_def)
      from mbisim have tbisim: "t. tbisim (ws1 t = None) t (ts1 t) m1 (ts2 t) m2" by(simp add: mbisim_def)
      hence tbisim': "t'. t'  t  tbisim (ws1 t' = None) t' (ts1 t') m1 (thr s2 t') m2" by(auto)
      from aoe have cao1: "r1.cond_action_oks (ls1, (ts1, m1), ws1, is1) t ta2c" by auto
      from tst' have "thr s2 t = (x2, no_wait_locks)"
        by(auto simp add: redT_updLns_def o_def finfun_Diag_const2)
      from cond_actions_oks_bisim_ex_τ2_inv[OF tbisim', OF _ tst this cao1]
      have red21': "τmRed2 s2 ?S2'" and tbisim'': "t'. t'  t  tbisim (ws1 t' = None) t' (ts1 t') m1 (thr ?S2' t') m2"
        and cao2: "r2.cond_action_oks ?S2' t ta2c" and tst'': "thr ?S2' t = (x2, no_wait_locks)"
        by(auto simp del: fun_upd_apply)
      note red21' moreover
      from tbisim'' tst'' tst have "t'. ts1 t' = None  thr ?S2' t' = None" by(force simp add: tbisim_def)
      from aoe thread_oks_bisim_inv[OF this nta] have "thread_oks (thr ?S2') ta2t" by simp
      with cao2 aoe have aoe': "r2.actions_ok ?S2' t ta2" by auto
      with red2 tst'' s1' tasim have "?S2' -2-tta2 ?s2'"
        by -(rule r2.redT_normal, auto simp add: ta_bisim_def)
      moreover from wakeup tasim
      have τ2: "¬ τmove2 (x2, m2) ta2 (x2', m2')" by(auto dest: r2.silent_tl)
      hence "¬ mτmove2 ?S2' (t, ta2) ?s2'"
      proof(rule contrapos_nn)
        assume: "mτmove2 ?S2' (t, ta2) ?s2'"
        thus "τmove2 (x2, m2) ta2 (x2', m2')" using tst'' tst'
          by cases auto
      qed
      moreover {
        note s1'
        moreover have "redT_upd ?S2' t ta2 x2' m2' ?s2'" using s1' tasim by(auto simp add: ta_bisim_def)
        moreover have "wset s1 = wset ?S2'" "locks s1 = locks ?S2'" by simp_all
        moreover have "wset s1' = wset ?s2'" by simp
        moreover have "interrupts s1' = interrupts ?s2'" by simp
        moreover have "finite (dom (thr s1))" by simp
        moreover from mbisim have "wset_thread_ok (wset s1) (thr s1)" by(rule mbisim_wset_thread_ok1)
        moreover from tst have "thr s1 t = (x1, no_wait_locks)" by simp
        moreover from tst'' have "thr ?S2' t = (x2, no_wait_locks)" by simp
        moreover note aoe aoe' tasim bisim'
        moreover have "wset s1' t = None  x1' ≈w x2'"
        proof(cases "wset s1' t")
          case None thus ?thesis ..
        next
          case (Some w')
          with redT_updWs_WokenUp_SuspendD[OF _ wakeup, of t "wset s1" "wset s1'" w'] s1'
          obtain w' where Suspend1: "Suspend w'  set ta1w" by(auto)
          with tasim have Suspend2: "Suspend w'  set ta2w" by(simp add: ta_bisim_def)
          with bisim rtranclp.rtrancl_refl red τ rtranclp.rtrancl_refl red2 τ2 bisim' tasim Suspend1
          have "x1' ≈w x2'" by(rule bisim_waitI)
          thus ?thesis ..
        qed
        moreover note rtranclp.rtrancl_refl
        moreover from red have "t  (x1, shr s1) -1-ta1 (x1', M1')" by simp
        moreover note rtranclp.rtrancl_refl
        moreover from red2 have "t  (x2, shr ?S2') -2-ta2 (x2', m2')" by simp
        moreover from bisim have "t  (x1, shr s1)  (x2, shr ?S2')" by simp
        moreover from τ have "¬ τmove1 (x1, shr s1) ta1 (x1', M1')" by simp
        moreover from τ2 have "¬ τmove2 (x2, shr ?S2') ta2 (x2', m2')" by simp
        moreover from tbisim'' have "t'. t  t'  tbisim (wset s1 t' = None) t' (thr s1 t') (shr s1) (thr ?S2' t') (shr ?S2')" by simp
        ultimately have "s1' ≈m ?s2'" by(rule mbisim_redT_upd) }
      moreover from tasim have "tl1 ∼T (t, ta2)" by simp
      ultimately show ?thesis unfolding s1' by blast
    qed
  next
    case (redT_acquire x1 n ln)
    hence [simp]: "ta1 = (K$ [], [], [], [], [], convert_RA ln)"
      and tst: "thr s1 t = (x1, ln)" and wst: "¬ waiting (wset s1 t)"
      and maa: "may_acquire_all (locks s1) t ln" and ln: "0 < ln $ n"
      and s1': "s1' = (acquire_all ls1 t ln, (ts1(t  (x1, no_wait_locks)), m1), ws1, is1)" by auto
    from tst mbisim obtain x2 where tst': "ts2 t = (x2, ln)" 
      and bisim: "t  (x1, m1)  (x2, m2)" by(auto dest: mbisim_thrD1)
    let ?s2' = "(acquire_all ls1 t ln, (ts2(t  (x2, no_wait_locks)), m2), ws1, is1)"
    from tst' wst maa ln have "s2 -2-t(K$ [], [], [], [], [], convert_RA ln) ?s2'"
      by-(rule r2.redT.redT_acquire, auto)
    moreover from tst' ln have "¬ mτmove2 s2 (t, (K$ [], [], [], [], [], convert_RA ln)) ?s2'"
      by(auto simp add: acquire_all_def fun_eq_iff elim!: r2.mτmove.cases)
    moreover have "mbisim s1' ?s2'"
    proof(rule mbisimI)
      from s1' show "locks s1' = locks ?s2'" by auto
    next
      from s1' show "wset s1' = wset ?s2'" by auto
    next
      from s1' show "interrupts s1' = interrupts ?s2'" by auto
    next
      fix t' assume "thr s1' t' = None"
      with s1' have "thr s1 t' = None" by(auto split: if_split_asm)
      with mbisim_thrNone_eq[OF mbisim] have "ts2 t' = None" by simp
      with tst' show "thr ?s2' t' = None" by auto
    next
      fix t' X1 LN
      assume ts't: "thr s1' t' = (X1, LN)"
      show "x2. thr ?s2' t' = (x2, LN)  t'  (X1, shr s1')  (x2, shr ?s2')  (wset ?s2' t' = None  X1 ≈w x2)"
      proof(cases "t' = t")
        case True
        with s1' tst ts't have [simp]: "X1 = x1" "LN = no_wait_locks" by simp_all
        with mbisim_thrD1[OF mbisim tst] bisim tst tst' True s1' wst show ?thesis by(auto)
      next
        case False
        with ts't s1' have "ts1 t' = (X1, LN)" by auto
        with mbisim obtain X2 where "ts2 t' = (X2, LN)" "t'  (X1, m1)  (X2, m2)" "wset ?s2' t' = None  X1 ≈w X2"
          by(auto dest: mbisim_thrD1)
        with False s1' show ?thesis by auto
      qed
    next
      from s1' show "finite (dom (thr s1'))" by auto
    next
      from mbisim_wset_thread_ok1[OF mbisim]
      show "wset_thread_ok (wset s1') (thr s1')" using s1' by(auto intro: wset_thread_ok_upd)
    qed
    moreover have "(t, K$ [], [], [], [], [], convert_RA ln) ∼T (t, K$ [], [], [], [], [], convert_RA ln)"
      by(simp add: ta_bisim_def)
    ultimately show ?thesis by fastforce
  qed
qed

theorem mbisim_simulation2:
  " mbisim s1 s2; r2.redT s2 tl2 s2'; ¬ mτmove2 s2 tl2 s2' 
   s1' s1'' tl1. r1.mthr.silent_moves s1 s1'  r1.redT s1' tl1 s1''  ¬ mτmove1 s1' tl1 s1'' 
                    mbisim s1'' s2'  mta_bisim tl1 tl2"
using FWdelay_bisimulation_obs.mbisim_simulation1[OF FWdelay_bisimulation_obs_flip]
unfolding flip_simps .

end

locale FWdelay_bisimulation_diverge =
  FWdelay_bisimulation_obs _ _ _ _ _ _ _ τmove1 τmove2
  for τmove1 :: "('l,'t,'x1,'m1,'w,'o) τmoves"
  and τmove2 :: "('l,'t,'x2,'m2,'w,'o) τmoves" +
  assumes delay_bisimulation_diverge_locale: "delay_bisimulation_diverge (r1 t) (r2 t) (bisim t) (ta_bisim bisim) τmove1 τmove2"

sublocale FWdelay_bisimulation_diverge <
  delay_bisimulation_diverge "r1 t" "r2 t" "bisim t" "ta_bisim bisim" τmove1 τmove2 for t
by(rule delay_bisimulation_diverge_locale)

context FWdelay_bisimulation_diverge begin

lemma FWdelay_bisimulation_diverge_flip:
  "FWdelay_bisimulation_diverge final2 r2 final1 r1 (λt. flip (bisim t)) (flip bisim_wait) τmove2 τmove1"
apply(rule FWdelay_bisimulation_diverge.intro)
 apply(rule FWdelay_bisimulation_obs_flip)
apply(rule FWdelay_bisimulation_diverge_axioms.intro)
apply(unfold flip_simps)
apply(rule delay_bisimulation_diverge_axioms)
done

end

lemma FWdelay_bisimulation_diverge_flip_simps [flip_simps]:
  "FWdelay_bisimulation_diverge final2 r2 final1 r1 (λt. flip (bisim t)) (flip bisim_wait) τmove2 τmove1 = 
   FWdelay_bisimulation_diverge final1 r1 final2 r2 bisim bisim_wait τmove1 τmove2"
by(auto dest: FWdelay_bisimulation_diverge.FWdelay_bisimulation_diverge_flip simp only: flip_flip)

context FWdelay_bisimulation_diverge begin

lemma bisim_inv1:
  assumes bisim: "t  s1  s2"
  and red: "t  s1 -1-ta1 s1'"
  obtains s2' where "t  s1'  s2'"
proof(atomize_elim)
  show "s2'. t  s1'  s2'"
  proof(cases "τmove1 s1 ta1 s1'")
    case True
    with red have "r1.silent_move t s1 s1'" by auto
    from simulation_silent1[OF bisim this]
    show ?thesis by auto
  next
    case False
    from simulation1[OF bisim red False] show ?thesis by auto
  qed
qed

lemma bisim_inv2:
  assumes "t  s1  s2" "t  s2 -2-ta2 s2'"
  obtains s1' where "t  s1'  s2'"
using assms FWdelay_bisimulation_diverge.bisim_inv1[OF FWdelay_bisimulation_diverge_flip]
unfolding flip_simps by blast

lemma bisim_inv: "bisim_inv"
by(blast intro!: bisim_invI elim: bisim_inv1 bisim_inv2)

lemma bisim_inv_τs1:
  assumes "t  s1  s2" and "r1.silent_moves t s1 s1'"
  obtains s2' where "t  s1'  s2'"
using assms by(rule bisim_inv_τs1_inv[OF bisim_inv])

lemma bisim_inv_τs2:
  assumes "t  s1  s2" and "r2.silent_moves t s2 s2'"
  obtains s1' where "t  s1'  s2'"
using assms by(rule bisim_inv_τs2_inv[OF bisim_inv])

lemma red1_rtrancl_τ_into_RedT_τ:
  assumes "r1.silent_moves t (x1, shr s1) (x1', m1')" "t  (x1, shr s1)  (x2, m2)"
  and "thr s1 t = (x1, no_wait_locks)" "wset s1 t = None"
  shows "τmRed1 s1 (redT_upd_ε s1 t x1' m1')"
using assms by(blast intro: r1.silent_moves_into_RedT_τ_inv)

lemma red2_rtrancl_τ_into_RedT_τ:
  assumes "r2.silent_moves t (x2, shr s2) (x2', m2')"
  and "t  (x1, m1)  (x2, shr s2)" "thr s2 t = (x2, no_wait_locks)" "wset s2 t = None"
  shows "τmRed2 s2 (redT_upd_ε s2 t x2' m2')"
using assms by(blast intro: r2.silent_moves_into_RedT_τ_inv)

lemma red1_rtrancl_τ_heapD:
  " r1.silent_moves t s1 s1'; t  s1  s2   snd s1' = snd s1"
by(blast intro: r1.red_rtrancl_τ_heapD_inv)

lemma red2_rtrancl_τ_heapD:
  " r2.silent_moves t s2 s2'; t  s1  s2   snd s2' = snd s2"
by(blast intro: r2.red_rtrancl_τ_heapD_inv)

lemma mbisim_simulation_silent1:
  assumes mτ': "r1.mthr.silent_move s1 s1'" and mbisim: "s1 ≈m s2"
  shows "s2'. r2.mthr.silent_moves s2 s2'  s1' ≈m s2'"
proof -
  from mτ' obtain tl1 where: "mτmove1 s1 tl1 s1'" "r1.redT s1 tl1 s1'" by auto
  obtain ls1 ts1 m1 ws1 is1 where [simp]: "s1 = (ls1, (ts1, m1), ws1, is1)" by(cases s1) fastforce
  obtain ls1' ts1' m1' ws1' is1' where [simp]: "s1' = (ls1', (ts1', m1'), ws1', is1')" by(cases s1') fastforce
  obtain ls2 ts2 m2 ws2 is2 where [simp]: "s2 = (ls2, (ts2, m2), ws2, is2)" by(cases s2) fastforce
  fromobtain t where "tl1 = (t, ε)" by(auto elim!: r1.mτmove.cases dest: r1.silent_tl)
  withhave: "mτmove1 s1 (t, ε) s1'" and redT1: "s1 -1-tε s1'" by simp_all
  fromobtain x x' ln' where tst: "ts1 t = (x, no_wait_locks)"
    and ts't: "ts1' t = (x', ln')" and τ: "τmove1 (x, m1) ε (x', m1')"
    by(fastforce elim: r1.mτmove.cases)
  from mbisim have [simp]: "ls2 = ls1" "ws2 = ws1" "is2 = is1" "finite (dom ts1)" by(auto simp add: mbisim_def)
  from redT1 show ?thesis
  proof cases
    case (redT_normal x1 x1' M')
    with tst ts't have [simp]: "x = x1" "x' = x1'"
      and red: "t  (x1, m1) -1-ε (x1', M')"
      and tst: "thr s1 t = (x1, no_wait_locks)"
      and wst: "wset s1 t = None"
      and s1': "redT_upd s1 t ε x1' M' s1'" by(auto)
    from s1' tst have [simp]: "ls1' = ls1" "ws1' = ws1" "is1' = is1" "M' = m1'" "ts1' = ts1(t  (x1', no_wait_locks))"
      by(auto simp add: redT_updLs_def redT_updLns_def o_def redT_updWs_def elim!: rtrancl3p_cases)
    from mbisim tst obtain x2 where tst': "ts2 t = (x2, no_wait_locks)"
      and bisim: "t  (x1, m1)  (x2, m2)" by(auto dest: mbisim_thrD1)
    from r1.τmove_heap[OF red] τ have [simp]: "m1 = M'" by simp
    from red τ have "r1.silent_move t (x1, m1) (x1', M')" by auto
    from simulation_silent1[OF bisim this]
    obtain x2' m2' where red: "r2.silent_moves t (x2, m2) (x2', m2')"
      and bisim': "t  (x1', m1)  (x2', m2')" by auto
    from red bisim have [simp]: "m2' = m2" 
      by(auto dest: red2_rtrancl_τ_heapD)
    let ?s2' = "redT_upd_ε s2 t x2' m2'"
    from red tst' wst bisim have "τmRed2 s2 ?s2'"
      by -(rule red2_rtrancl_τ_into_RedT_τ, auto)
    moreover have "mbisim s1' ?s2'"
    proof(rule mbisimI)
      show "locks s1' = locks ?s2'" "wset s1' = wset ?s2'" "interrupts s1' = interrupts ?s2'" by auto
    next
      fix t'
      assume "thr s1' t' = None"
      hence "ts1 t' = None" by(auto split: if_split_asm)
      with mbisim_thrNone_eq[OF mbisim] have "ts2 t' = None" by simp
      with tst' show "thr ?s2' t' = None" by auto
    next
      fix t' X1 LN
      assume ts't': "thr s1' t' = (X1, LN)"
      show "x2. thr ?s2' t' = (x2, LN)  t'  (X1, shr s1')  (x2, shr ?s2')  (wset ?s2' t' = None  X1 ≈w x2)"
      proof(cases "t' = t")
        case True
        note this[simp]
        with s1' tst ts't' have [simp]: "X1 = x1'" "LN = no_wait_locks"
          by(simp_all)(auto simp add: redT_updLns_def o_def finfun_Diag_const2)
        with bisim' tst' wst show ?thesis by(auto simp add: redT_updLns_def o_def finfun_Diag_const2)
      next
        case False
        with ts't' have "ts1 t' = (X1, LN)" by auto
        with mbisim obtain X2 where "ts2 t' = (X2, LN)" "t'  (X1, m1)  (X2, m2)" "ws1 t' = None  X1 ≈w X2"
          by(auto dest: mbisim_thrD1)
        with False show ?thesis by auto
      qed
    next
      show "finite (dom (thr s1'))" by simp
    next
      from mbisim_wset_thread_ok1[OF mbisim]
      show "wset_thread_ok (wset s1') (thr s1')" by(auto intro: wset_thread_ok_upd)
    qed
    ultimately show ?thesis by(auto)
  next
    case redT_acquire
    with tst have False by auto
    thus ?thesis ..
  qed
qed

lemma mbisim_simulation_silent2:
  " mbisim s1 s2; r2.mthr.silent_move s2 s2' 
   s1'. r1.mthr.silent_moves s1 s1'  mbisim s1' s2'"
using FWdelay_bisimulation_diverge.mbisim_simulation_silent1[OF FWdelay_bisimulation_diverge_flip]
unfolding flip_simps .

lemma mbisim_simulation1':
  assumes mbisim: "mbisim s1 s2" and "¬ mτmove1 s1 tl1 s1'" "r1.redT s1 tl1 s1'"
  shows "s2' s2'' tl2. r2.mthr.silent_moves s2 s2'  r2.redT s2' tl2 s2'' 
                        ¬ mτmove2 s2' tl2 s2''  mbisim s1' s2''  mta_bisim tl1 tl2"
using mbisim_simulation1 assms .

lemma mbisim_simulation2':
  " mbisim s1 s2; r2.redT s2 tl2 s2'; ¬ mτmove2 s2 tl2 s2' 
   s1' s1'' tl1. r1.mthr.silent_moves s1 s1'  r1.redT s1' tl1 s1''  ¬ mτmove1 s1' tl1 s1'' 
                    mbisim s1'' s2'  mta_bisim tl1 tl2"
using FWdelay_bisimulation_diverge.mbisim_simulation1'[OF FWdelay_bisimulation_diverge_flip]
unfolding flip_simps .

lemma mτdiverge_simulation1:
  assumes "s1 ≈m s2"
  and "r1.mthr.τdiverge s1"
  shows "r2.mthr.τdiverge s2"
proof -
  from s1 ≈m s2 have "finite (dom (thr s1))"
    by(rule mbisim_finite1)+
  from r1.τdiverge_τmredTD[OF ‹r1.mthr.τdiverge s1 this]
  obtain t x where "thr s1 t = (x, no_wait_locks)" "wset s1 t = None" "r1.τdiverge t (x, shr s1)" by blast
  from s1 ≈m s2 ‹thr s1 t = (x, no_wait_locks) obtain x'
    where "thr s2 t = (x', no_wait_locks)" "t  (x, shr s1)  (x', shr s2)"
    by(auto dest: mbisim_thrD1)
  from s1 ≈m s2 ‹wset s1 t = None› have "wset s2 t = None" by(simp add: mbisim_def)
  from t  (x, shr s1)  (x', shr s2) ‹r1.τdiverge t (x, shr s1)
  have "r2.τdiverge t (x', shr s2)" by(simp add: τdiverge_bisim_inv)
  thus ?thesis using ‹thr s2 t = (x', no_wait_locks) ‹wset s2 t = None›
    by(rule r2.τdiverge_into_τmredT)
qed

lemma τdiverge_mbisim_inv:
  "s1 ≈m s2  r1.mthr.τdiverge s1  r2.mthr.τdiverge s2"
apply(rule iffI)
 apply(erule (1) mτdiverge_simulation1)
by(rule FWdelay_bisimulation_diverge.mτdiverge_simulation1[OF FWdelay_bisimulation_diverge_flip, unfolded flip_simps])

lemma mbisim_delay_bisimulation:
  "delay_bisimulation_diverge r1.redT r2.redT mbisim mta_bisim mτmove1 mτmove2"
apply(unfold_locales)
apply(rule mbisim_simulation1 mbisim_simulation2 mbisim_simulation_silent1 mbisim_simulation_silent2 τdiverge_mbisim_inv|assumption)+
done

theorem mdelay_bisimulation_final_base:
  "delay_bisimulation_final_base r1.redT r2.redT mbisim mτmove1 mτmove2 r1.mfinal r2.mfinal"
apply(unfold_locales)
apply(blast dest: mfinal1_simulation mfinal2_simulation)+
done

end

sublocale FWdelay_bisimulation_diverge < mthr: delay_bisimulation_diverge r1.redT r2.redT mbisim mta_bisim mτmove1 mτmove2
by(rule mbisim_delay_bisimulation)

sublocale FWdelay_bisimulation_diverge <
  mthr: delay_bisimulation_final_base r1.redT r2.redT mbisim mta_bisim mτmove1 mτmove2 r1.mfinal r2.mfinal
by(rule mdelay_bisimulation_final_base)

context FWdelay_bisimulation_diverge begin

lemma mthr_delay_bisimulation_diverge_final:
  "delay_bisimulation_diverge_final r1.redT r2.redT mbisim mta_bisim mτmove1 mτmove2 r1.mfinal r2.mfinal"
by(unfold_locales)

end

sublocale FWdelay_bisimulation_diverge <
  mthr: delay_bisimulation_diverge_final r1.redT r2.redT mbisim mta_bisim mτmove1 mτmove2 r1.mfinal r2.mfinal
by(rule mthr_delay_bisimulation_diverge_final)

subsection ‹Strong bisimulation as corollary›

locale FWbisimulation = FWbisimulation_base _ _ _ r2 convert_RA bisim "λx1 x2. True" +
  r1: multithreaded final1 r1 convert_RA +
  r2: multithreaded final2 r2 convert_RA
  for r2 :: "('l,'t,'x2,'m2,'w,'o) semantics" ("_  _ -2-_ _" [50,0,0,50] 80)
  and convert_RA :: "'l released_locks  'o list"
  and bisim :: "'t  ('x1 × 'm1, 'x2 × 'm2) bisim" ("_  _/  _" [50, 50, 50] 60) +
  assumes bisimulation_locale: "bisimulation (r1 t) (r2 t) (bisim t) (ta_bisim bisim)"
  and bisim_final: "t  (x1, m1)  (x2, m2)  final1 x1  final2 x2"
  and bisim_inv_red_other:
   " t'  (x, m1)  (xx, m2); t  (x1, m1)  (x2, m2); 
      t  (x1, m1) -1-ta1 (x1', m1'); t  (x2, m2) -2-ta2 (x2', m2'); 
      t  (x1', m1')  (x2', m2'); ta_bisim bisim ta1 ta2 
    t'  (x, m1')  (xx, m2')"
  and ex_final1_conv_ex_final2:
   "(x1. final1 x1)  (x2. final2 x2)"

sublocale FWbisimulation < bisim?: bisimulation "r1 t" "r2 t" "bisim t" "ta_bisim bisim" for t
by(rule bisimulation_locale)

sublocale FWbisimulation < bisim_diverge?:
  FWdelay_bisimulation_diverge final1 r1 final2 r2 convert_RA bisim "λx1 x2. True" "λs ta s'. False" "λs ta s'. False"
proof -
  interpret biw: bisimulation_into_delay "r1 t" "r2 t" "bisim t" "ta_bisim bisim" "λs ta s'. False" "λs ta s'. False"
    for t
    by(unfold_locales) simp
  show "FWdelay_bisimulation_diverge final1 r1 final2 r2 bisim (λx1 x2. True) (λs ta s'. False) (λs ta s'. False)"
  proof(unfold_locales)
    fix t' x m1 xx m2 x1 x2 t x1' ta1 x1'' m1' x2' ta2 x2'' m2'
    assume bisim: "t'  (x, m1)  (xx, m2)" and bisim12: "t  (x1, m1)  (x2, m2)"
      and τ1: "τtrsys.silent_moves (r1 t) (λs ta s'. False) (x1, m1) (x1', m1)" 
      and red1: "t  (x1', m1) -1-ta1 (x1'', m1')"
      and τ2: "τtrsys.silent_moves (r2 t) (λs ta s'. False) (x2, m2) (x2', m2)"
      and red2: "t  (x2', m2) -2-ta2 (x2'', m2')"
      and bisim12': "t  (x1'', m1')  (x2'', m2')" and tasim: "ta1 ∼m ta2"
    from τ1 τ2 have [simp]: "x1' = x1" "x2' = x2" by(simp_all add: rtranclp_False τmoves_False)
    from bisim12 bisim_inv_red_other[OF bisim _ red1 red2 bisim12' tasim]
    show "t'  (x, m1')  (xx, m2')" by simp
  next
    fix t x1 m1 x2 m2 ta1 x1' m1'
    assume "t  (x1, m1)  (x2, m2)" "t  (x1, m1) -1-ta1 (x1', m1')"
    from simulation1[OF this]
    show "ta2 x2' m2'. t  (x2, m2) -2-ta2 (x2', m2')  t  (x1', m1')  (x2', m2')  ta1 ∼m ta2"
      by auto
  next
    fix t x1 m1 x2 m2 ta2 x2' m2'
    assume "t  (x1, m1)  (x2, m2)" "t  (x2, m2) -2-ta2 (x2', m2')"
    from simulation2[OF this]
    show "ta1 x1' m1'. t  (x1, m1) -1-ta1 (x1', m1')  t  (x1', m1')  (x2', m2')  ta1 ∼m ta2"
      by auto
  next
    show "(x1. final1 x1)  (x2. final2 x2)" by(rule ex_final1_conv_ex_final2)
  qed(fastforce simp add: bisim_final)+
qed

context FWbisimulation begin

lemma FWbisimulation_flip: "FWbisimulation final2 r2 final1 r1 (λt. flip (bisim t))"
apply(rule FWbisimulation.intro)
  apply(rule r2.multithreaded_axioms)
 apply(rule r1.multithreaded_axioms)
apply(rule FWbisimulation_axioms.intro)
   apply(unfold flip_simps)
   apply(rule bisimulation_axioms)
  apply(erule bisim_final[symmetric])
 apply(erule (5) bisim_inv_red_other)
apply(rule ex_final1_conv_ex_final2[symmetric])
done

end

lemma FWbisimulation_flip_simps [flip_simps]:
  "FWbisimulation final2 r2 final1 r1 (λt. flip (bisim t)) = FWbisimulation final1 r1 final2 r2 bisim"
by(auto dest: FWbisimulation.FWbisimulation_flip simp only: flip_flip)

context FWbisimulation begin

text ‹
  The notation for mbisim is lost because @{term "bisim_wait"} is instantiated to @{term "λx1 x2. True"}.
  This reintroduces the syntax, but it does not work for output mode. This would require a new abbreviation.
›
notation mbisim ("_ ≈m _" [50, 50] 60)

theorem mbisim_bisimulation:
  "bisimulation r1.redT r2.redT mbisim mta_bisim"
proof
  fix s1 s2 tta1 s1'
  assume mbisim: "s1 ≈m s2" and "r1.redT s1 tta1 s1'"
  from mthr.simulation1[OF this]
  show "s2' tta2. r2.redT s2 tta2 s2'  s1' ≈m s2'  tta1 ∼T tta2"
    by(auto simp add: τmoves_False mτmove_False)
next
  fix s2 s1 tta2 s2'
  assume "s1 ≈m s2" and "r2.redT s2 tta2 s2'"
  from mthr.simulation2[OF this]
  show "s1' tta1. r1.redT s1 tta1 s1'  s1' ≈m s2'  tta1 ∼T tta2"
    by(auto simp add: τmoves_False mτmove_False)
qed

lemma mbisim_wset_eq:
  "s1 ≈m s2  wset s1 = wset s2"
by(simp add: mbisim_def)

lemma mbisim_mfinal:
  "s1 ≈m s2  r1.mfinal s1  r2.mfinal s2"
apply(auto intro!: r2.mfinalI r1.mfinalI dest: mbisim_thrD2 mbisim_thrD1 bisim_final elim: r1.mfinalE r2.mfinalE)
apply(frule (1) mbisim_thrD2, drule mbisim_wset_eq, auto elim: r1.mfinalE)
apply(frule (1) mbisim_thrD1, drule mbisim_wset_eq, auto elim: r2.mfinalE)
done

end

sublocale FWbisimulation < mthr: bisimulation r1.redT r2.redT mbisim mta_bisim
by(rule mbisim_bisimulation)

sublocale FWbisimulation < mthr: bisimulation_final r1.redT r2.redT mbisim mta_bisim r1.mfinal r2.mfinal
by(unfold_locales)(rule mbisim_mfinal)

end

Theory FWBisimDeadlock

(*  Title:      JinjaThreads/Framework/FWBisimDeadlock.thy
    Author:     Andreas Lochbihler
*)

section ‹Preservation of deadlock across bisimulations›

theory FWBisimDeadlock
imports
  FWBisimulation
  FWDeadlock
begin

context FWdelay_bisimulation_obs begin

lemma actions_ok1_ex_actions_ok2:
  assumes "r1.actions_ok s1 t ta1"
  and "ta1 ∼m ta2"
  obtains s2 where "r2.actions_ok s2 t ta2"
proof -
  let ?s2 = "(locks s1, (λt. map_option (λ(x1, ln). (SOME x2. if final1 x1 then final2 x2 else ¬ final2 x2, ln)) (thr s1 t), undefined), wset s1, interrupts s1)"
  from ta1 ∼m ta2 have "ta1c = ta2c" by(simp add: ta_bisim_def)
  with ‹r1.actions_ok s1 t ta1 have cao1: "r1.cond_action_oks s1 t ta2c" by auto
  have "r2.cond_action_oks ?s2 t ta2c" unfolding r2.cond_action_oks_conv_set
  proof
    fix ct
    assume "ct  set ta2c"
    with cao1 have "r1.cond_action_ok s1 t ct"
      unfolding r1.cond_action_oks_conv_set by auto
    thus "r2.cond_action_ok ?s2 t ct" using ex_final1_conv_ex_final2
      by(cases ct)(fastforce intro: someI_ex[where P=final2])+
  qed
  hence "r2.actions_ok ?s2 t ta2"
    using assms by(auto simp add: ta_bisim_def split del: if_split elim: rev_iffD1[OF _ thread_oks_bisim_inv])
  thus thesis by(rule that)
qed

lemma actions_ok2_ex_actions_ok1:
  assumes "r2.actions_ok s2 t ta2"
  and "ta1 ∼m ta2"
  obtains s1 where "r1.actions_ok s1 t ta1"
using FWdelay_bisimulation_obs.actions_ok1_ex_actions_ok2[OF FWdelay_bisimulation_obs_flip] assms
unfolding flip_simps .

lemma ex_actions_ok1_conv_ex_actions_ok2:
  "ta1 ∼m ta2  (s1. r1.actions_ok s1 t ta1)  (s2. r2.actions_ok s2 t ta2)"
by(metis actions_ok1_ex_actions_ok2 actions_ok2_ex_actions_ok1)

end

context FWdelay_bisimulation_diverge begin

lemma no_τMove1_τs_to_no_τMove2:
  fixes no_τmoves1 no_τmoves2
  defines "no_τmoves1  λs1 t. wset s1 t = None  (x. thr s1 t = (x, no_wait_locks)  (x' m'. ¬ r1.silent_move t (x, shr s1) (x', m')))"
  defines "no_τmoves2  λs2 t. wset s2 t = None  (x. thr s2 t = (x, no_wait_locks)  (x' m'. ¬ r2.silent_move t (x, shr s2) (x', m')))"
  assumes mbisim: "s1 ≈m (ls2, (ts2, m2), ws2, is2)"
  
  shows "ts2'. r2.mthr.silent_moves (ls2, (ts2, m2), ws2, is2) (ls2, (ts2', m2), ws2, is2)  
                (t. no_τmoves1 s1 t  no_τmoves2 (ls2, (ts2', m2), ws2, is2) t)  s1 ≈m (ls2, (ts2', m2), ws2, is2)"
proof -
  from mbisim have "finite (dom (thr s1))" by(simp add: mbisim_def)
  hence "finite {t. no_τmoves1 s1 t}" unfolding no_τmoves1_def
    by-(rule finite_subset, auto)
  thus ?thesis using s1 ≈m (ls2, (ts2, m2), ws2, is2)
  proof(induct A"{t. no_τmoves1 s1 t}" arbitrary: s1 ts2 rule: finite_induct)
    case empty
    from {} = {t. no_τmoves1 s1 t}[symmetric] have "no_τmoves1 s1 = (λt. False)"
      by(auto intro: ext)
    thus ?case using s1 ≈m (ls2, (ts2, m2), ws2, is2) by auto
  next
    case (insert t A)
    note mbisim = s1 ≈m (ls2, (ts2, m2), ws2, is2)
    from ‹insert t A = {t. no_τmoves1 s1 t}
    have "no_τmoves1 s1 t" by auto
    then obtain x1 where ts1t: "thr s1 t = (x1, no_wait_locks)"
      and ws1t: "wset s1 t = None"
      and τ1: "x1m1'. ¬ r1.silent_move t (x1, shr s1) x1m1'"
      by(auto simp add: no_τmoves1_def)

    from ts1t mbisim obtain x2 where ts2t: "ts2 t = (x2, no_wait_locks)"
      and "t  (x1, shr s1)  (x2, m2)" by(auto dest: mbisim_thrD1)
    from mbisim ws1t have "ws2 t = None" by(simp add: mbisim_def)

    let ?s1 = "(locks s1, ((thr s1)(t := None), shr s1), wset s1, interrupts s1)"
    let ?s2 = "(ls2, (ts2(t := None), m2), ws2, is2)"
    from ‹insert t A = {t. no_τmoves1 s1 t} t  A
    have A: "A = {t. no_τmoves1 ?s1 t}" by(auto simp add: no_τmoves1_def)
    have "?s1 ≈m ?s2"
    proof(rule mbisimI)
      from mbisim
      show "finite (dom (thr ?s1))" "locks ?s1 = locks ?s2" "wset ?s1 = wset ?s2" "interrupts ?s1 = interrupts ?s2"
        by(simp_all add: mbisim_def)
    next
      from mbisim_wset_thread_ok1[OF mbisim] ws1t show "wset_thread_ok (wset ?s1) (thr ?s1)"
        by(auto intro!: wset_thread_okI dest: wset_thread_okD split: if_split_asm)
    next
      fix t'
      assume "thr ?s1 t' = None"
      with mbisim_thrNone_eq[OF mbisim, of t']
      show "thr ?s2 t' = None" by auto
    next
      fix t' x1 ln
      assume "thr ?s1 t' = (x1, ln)"
      hence "thr s1 t' = (x1, ln)" "t'  t" by(auto split: if_split_asm)
      with mbisim_thrD1[OF mbisim ‹thr s1 t' = (x1, ln)] mbisim
      show "x2. thr ?s2 t' = (x2, ln)  t'  (x1, shr ?s1)  (x2, shr ?s2)  (wset ?s2 t' = None  x1 ≈w x2)"
        by(auto simp add: mbisim_def)
    qed
    with A have "ts2'. r2.mthr.silent_moves ?s2 (ls2, (ts2', m2), ws2, is2)  (t. no_τmoves1 ?s1 t  no_τmoves2 (ls2, (ts2', m2), ws2, is2) t)  ?s1 ≈m (ls2, (ts2', m2), ws2, is2)" by(rule insert)
    then obtain ts2' where "r2.mthr.silent_moves ?s2 (ls2, (ts2', m2), ws2, is2)"
      and no_τ: "t. no_τmoves1 ?s1 t  no_τmoves2 (ls2, (ts2', m2), ws2, is2) t"
      and "?s1 ≈m (ls2, (ts2', m2), ws2, is2)" by auto
    let ?s2' = "(ls2, (ts2'(t  (x2, no_wait_locks)), m2), ws2, is2)"
    from ts2t have "ts2(t  (x2, no_wait_locks)) = ts2" by(auto intro: ext)
    with r2.τmRedT_add_thread_inv[OF ‹r2.mthr.silent_moves ?s2 (ls2, (ts2', m2), ws2, is2), of t "(x2, no_wait_locks)"]
    have "r2.mthr.silent_moves (ls2, (ts2, m2), ws2, is2) ?s2'" by simp
    from no_τmove1_τs_to_no_τmove2[OF t  (x1, shr s1)  (x2, m2) τ1]
    obtain x2' m2' where "r2.silent_moves t (x2, m2) (x2', m2')" 
      and "x2'' m2''. ¬ r2.silent_move t (x2', m2') (x2'', m2'')" 
      and "t  (x1, shr s1)  (x2', m2')" by auto
    let ?s2'' = "(ls2, (ts2'(t  (x2', no_wait_locks)), m2'), ws2, is2)"
    from red2_rtrancl_τ_heapD[OF ‹r2.silent_moves t (x2, m2) (x2', m2') t  (x1, shr s1)  (x2, m2)]
    have "m2' = m2" by simp
    with ‹r2.silent_moves t (x2, m2) (x2', m2') have "r2.silent_moves t (x2, shr ?s2') (x2', m2)" by simp
    hence "r2.mthr.silent_moves ?s2' (redT_upd_ε ?s2' t x2' m2)"
      by(rule red2_rtrancl_τ_into_RedT_τ)(auto simp add: ws2 t = None› intro: t  (x1, shr s1)  (x2, m2))
    also have "redT_upd_ε ?s2' t x2' m2 = ?s2''" using m2' = m2
      by(auto simp add: fun_eq_iff redT_updLns_def finfun_Diag_const2 o_def)
    finally (back_subst) have "r2.mthr.silent_moves (ls2, (ts2, m2), ws2, is2) ?s2''" 
      using ‹r2.mthr.silent_moves (ls2, (ts2, m2), ws2, is2) ?s2' by-(rule rtranclp_trans)
    moreover {
      fix t'
      assume no_τ1: "no_τmoves1 s1 t'"
      have "no_τmoves2 ?s2'' t'"
      proof(cases "t' = t")
        case True thus ?thesis
          using ws2 t = None› x2'' m2''. ¬ r2.silent_move t (x2', m2') (x2'', m2'') by(simp add: no_τmoves2_def)
      next
        case False
        with no_τ1 have "no_τmoves1 ?s1 t'" by(simp add: no_τmoves1_def)
        hence "no_τmoves2 (ls2, (ts2', m2), ws2, is2) t'"
          by(rule no_τmoves1 ?s1 t'  no_τmoves2 (ls2, (ts2', m2), ws2, is2) t')
        with False m2' = m2 show ?thesis by(simp add: no_τmoves2_def)
      qed }
    moreover have "s1 ≈m ?s2''"
    proof(rule mbisimI)
      from mbisim
      show "finite (dom (thr s1))" "locks s1 = locks ?s2''" "wset s1 = wset ?s2''" "interrupts s1 = interrupts ?s2''"
        by(simp_all add: mbisim_def)
    next
      from mbisim show "wset_thread_ok (wset s1) (thr s1)" by(rule mbisim_wset_thread_ok1)
    next
      fix t'
      assume "thr s1 t' = None"
      hence "thr ?s1 t' = None" "t'  t" using ts1t by auto
      with mbisim_thrNone_eq[OF ?s1 ≈m (ls2, (ts2', m2), ws2, is2), of t']
      show "thr ?s2'' t' = None" by simp
    next
      fix t' x1' ln'
      assume "thr s1 t' = (x1', ln')"
      show "x2. thr ?s2'' t' = (x2, ln')  t'  (x1', shr s1)  (x2, shr ?s2'')  (wset ?s2'' t' = None  x1' ≈w x2)"
      proof(cases "t = t'")
        case True
        with ‹thr s1 t' = (x1', ln') ts1t t  (x1, shr s1)  (x2', m2') m2' = m2 ws2 t = None›
        show ?thesis by auto
      next
        case False
        with mbisim_thrD1[OF ?s1 ≈m (ls2, (ts2', m2), ws2, is2), of t' x1' ln'] ‹thr s1 t' = (x1', ln') m2' = m2 mbisim
        show ?thesis by(auto simp add: mbisim_def)
      qed
    qed
    ultimately show ?case unfolding m2' = m2 by blast
  qed
qed

lemma no_τMove2_τs_to_no_τMove1:
  fixes no_τmoves1 no_τmoves2
  defines "no_τmoves1  λs1 t. wset s1 t = None  (x. thr s1 t = (x, no_wait_locks)  (x' m'. ¬ r1.silent_move t (x, shr s1) (x', m')))"
  defines "no_τmoves2  λs2 t. wset s2 t = None  (x. thr s2 t = (x, no_wait_locks)  (x' m'. ¬ r2.silent_move t (x, shr s2) (x', m')))"
  assumes "(ls1, (ts1, m1), ws1, is1) ≈m s2"
  
  shows "ts1'. r1.mthr.silent_moves (ls1, (ts1, m1), ws1, is1) (ls1, (ts1', m1), ws1, is1) 
                (t. no_τmoves2 s2 t  no_τmoves1 (ls1, (ts1', m1), ws1, is1) t)  (ls1, (ts1', m1), ws1, is1) ≈m s2"
using assms FWdelay_bisimulation_diverge.no_τMove1_τs_to_no_τMove2[OF FWdelay_bisimulation_diverge_flip]
unfolding flip_simps by blast

lemma deadlock_mbisim_not_final_thread_pres:
  assumes dead: "t  r1.deadlocked s1  r1.deadlock s1"
  and nfin: "r1.not_final_thread s1 t"
  and fin: "r1.final_thread s1 t  r2.final_thread s2 t"
  and mbisim: "s1 ≈m s2"
  shows "r2.not_final_thread s2 t"
proof -
  from nfin obtain x1 ln where "thr s1 t = (x1, ln)" by cases auto
  with mbisim obtain x2 where "thr s2 t = (x2, ln)" "t  (x1, shr s1)  (x2, shr s2)" "wset s1 t = None  x1 ≈w x2" 
    by(auto dest: mbisim_thrD1)
  show "r2.not_final_thread s2 t"
  proof(cases "wset s1 t = None  ln = no_wait_locks")
    case False
    with ‹r1.not_final_thread s1 t ‹thr s1 t = (x1, ln) ‹thr s2 t = (x2, ln) mbisim 
    show ?thesis by cases(auto simp add: mbisim_def r2.not_final_thread_iff)
  next
    case True
    with ‹r1.not_final_thread s1 t ‹thr s1 t = (x1, ln) have "¬ final1 x1" by(cases) auto
    have "¬ final2 x2"
    proof
      assume "final2 x2"
      with final2_simulation[OF t  (x1, shr s1)  (x2, shr s2)]
      obtain x1' m1' where "r1.silent_moves t (x1, shr s1) (x1', m1')" "t  (x1', m1')  (x2, shr s2)" "final1 x1'" by auto
      from ‹r1.silent_moves t (x1, shr s1) (x1', m1') have "x1' = x1"
      proof(cases rule: converse_rtranclpE2[consumes 1, case_names refl step])
        case (step x1'' m1'')
        from ‹r1.silent_move t (x1, shr s1) (x1'', m1'')
        have "t  (x1, shr s1) -1-ε (x1'', m1'')" by(auto dest: r1.silent_tl)
        hence "r1.redT s1 (t, ε) (redT_upd_ε s1 t x1'' m1'')"
          using ‹thr s1 t = (x1, ln) True
          by -(erule r1.redT_normal, auto simp add: redT_updLns_def finfun_Diag_const2 o_def redT_updWs_def)
        hence False using dead by(auto intro: r1.deadlock_no_red r1.red_no_deadlock)
        thus ?thesis ..
      qed simp
      with ¬ final1 x1 final1 x1' show False by simp
    qed
    thus ?thesis using ‹thr s2 t = (x2, ln) by(auto simp add: r2.not_final_thread_iff)
  qed
qed

lemma deadlocked1_imp_τs_deadlocked2:
  assumes mbisim: "s1 ≈m s2"
  and dead: "t  r1.deadlocked s1"
  shows "s2'. r2.mthr.silent_moves s2 s2'  t  r2.deadlocked s2'  s1 ≈m s2'"
proof -
  from mfinal1_inv_simulation[OF mbisim]
  obtain ls2 ts2 m2 ws2 is2 where red1: "r2.mthr.silent_moves s2 (ls2, (ts2, m2), ws2, is2)"
    and "s1 ≈m (ls2, (ts2, m2), ws2, is2)" and "m2 = shr s2" 
    and fin: "t. r1.final_thread s1 t  r2.final_thread (ls2, (ts2, m2), ws2, is2) t" by fastforce
  from no_τMove1_τs_to_no_τMove2[OF s1 ≈m (ls2, (ts2, m2), ws2, is2)]
  obtain ts2' where red2: "r2.mthr.silent_moves (ls2, (ts2, m2), ws2, is2) (ls2, (ts2', m2), ws2, is2)"
    and no_τ: "t x1 x2 x2' m2'.  wset s1 t = None; thr s1 t = (x1, no_wait_locks); ts2' t = (x2, no_wait_locks);
                           x' m'. r1.silent_move t (x1, shr s1) (x', m')  False 
                ¬ r2.silent_move t (x2, m2) (x2', m2')"
    and mbisim: "s1 ≈m (ls2, (ts2', m2), ws2, is2)" by fastforce
  from mbisim have mbisim_eqs: "ls2 = locks s1" "ws2 = wset s1" "is2 = interrupts s1"
    by(simp_all add: mbisim_def)
  let ?s2 = "(ls2, (ts2', m2), ws2, is2)"
  from red2 have fin': "t. r1.final_thread s1 t  r2.final_thread ?s2 t"
    by(rule r2.τmRedT_preserves_final_thread)(rule fin)
  from dead
  have "t  r2.deadlocked ?s2"
  proof(coinduct)
    case (deadlocked t)
    thus ?case
    proof(cases rule: r1.deadlocked_elims)
      case (lock x1)
      hence csmw: "LT. r1.can_sync t x1 (shr s1) LT 
                   ltLT. r1.must_wait s1 t lt (r1.deadlocked s1  r1.final_threads s1)"
        by blast
      from ‹thr s1 t = (x1, no_wait_locks) mbisim obtain x2
        where "ts2' t = (x2, no_wait_locks)" and bisim: "t  (x1, shr s1)  (x2, m2)"
        by(auto dest: mbisim_thrD1)
      note ts2' t = (x2, no_wait_locks) moreover
      { from ‹r1.must_sync t x1 (shr s1) obtain ta1 x1' m1'
          where r1: "t  (x1, shr s1) -1-ta1 (x1', m1')"
          and s1': "s1'. r1.actions_ok s1' t ta1" by(fastforce elim: r1.must_syncE)
        have "¬ τmove1 (x1, shr s1) ta1 (x1', m1')" (is "¬ ")
        proof
          assume ""
          hence "ta1 = ε" by(rule r1.silent_tl)
          with r1 have "r1.can_sync t x1 (shr s1) {}"
            by(auto intro!: r1.can_syncI simp add: collect_locks_def collect_interrupts_def)
          from csmw[OF this] show False by blast
        qed
        from simulation1[OF bisim r1 this]
        obtain x2' m2' x2'' m2'' ta2 where r2: "r2.silent_moves t (x2, m2) (x2', m2')"
          and r2': "t  (x2', m2') -2-ta2  (x2'', m2'')"
          and τ2: "¬ τmove2 (x2', m2') ta2 (x2'', m2'')"
          and bisim': "t  (x1', m1')  (x2'', m2'')" and tasim: "ta1 ∼m ta2" by auto
        from r2
        have "ta2 x2' m2' s2'. t  (x2, m2) -2-ta2 (x2', m2')  r2.actions_ok s2' t ta2"
        proof(cases rule: converse_rtranclpE2[consumes 1, case_names base step])
          case base
          from r2'[folded base] s1'[unfolded ex_actions_ok1_conv_ex_actions_ok2[OF tasim]]
          show ?thesis by blast
        next
          case (step x2''' m2''')
          hence "t  (x2, m2) -2-ε (x2''', m2''')" by(auto dest: r2.silent_tl)
          moreover have "r2.actions_ok (undefined, (undefined, undefined), Map.empty, undefined) t ε" by auto
          ultimately show ?thesis by-(rule exI conjI|assumption)+
        qed
        hence "r2.must_sync t x2 m2" unfolding r2.must_sync_def2 . }
      moreover
      { fix LT
        assume "r2.can_sync t x2 m2 LT"
        then obtain ta2 x2' m2' where r2: "t  (x2, m2) -2-ta2 (x2', m2')"
          and LT: "LT = collect_locks ta2l <+> collect_cond_actions ta2c <+> collect_interrupts ta2i"
          by(auto elim: r2.can_syncE)
        from ‹wset s1 t = None› ‹thr s1 t = (x1, no_wait_locks) ts2' t = (x2, no_wait_locks)
        have "¬ r2.silent_move t (x2, m2) (x2', m2')"
        proof(rule no_τ)
          fix x1' m1'
          assume "r1.silent_move t (x1, shr s1) (x1', m1')"
          hence "t  (x1, shr s1) -1-ε (x1', m1')" by(auto dest: r1.silent_tl)
          hence "r1.can_sync t x1 (shr s1) {}"
            by(auto intro: r1.can_syncI simp add: collect_locks_def collect_interrupts_def)
          with csmw[OF this] show False by blast
        qed
        with r2 have "¬ τmove2 (x2, m2) ta2 (x2', m2')" by auto
        from simulation2[OF bisim r2 this] obtain x1' m1' x1'' m1'' ta1
          where τr1: "r1.silent_moves t (x1, shr s1) (x1', m1')"
          and r1: "t  (x1', m1') -1-ta1 (x1'', m1'')"
          and nτ1: "¬ τmove1 (x1', m1') ta1 (x1'', m1'')"
          and bisim': "t  (x1'', m1'')  (x2', m2')"
          and tlsim: "ta1 ∼m ta2" by auto
        from τr1 obtain [simp]: "x1' = x1" "m1' = shr s1"
        proof(cases rule: converse_rtranclpE2[consumes 1, case_names refl step])
          case (step X M)
          from ‹r1.silent_move t (x1, shr s1) (X, M)
          have "t  (x1, shr s1) -1-ε (X, M)" by(auto dest: r1.silent_tl)
          hence "r1.can_sync t x1 (shr s1) {}"
            by(auto intro: r1.can_syncI simp add: collect_locks_def collect_interrupts_def)
          with csmw[OF this] have False by blast
          thus ?thesis ..
        qed blast
        from tlsim LT have "LT = collect_locks ta1l <+> collect_cond_actions ta1c <+> collect_interrupts ta1i"
          by(auto simp add: ta_bisim_def)
        with r1 have "r1.can_sync t x1 (shr s1) LT" by(auto intro: r1.can_syncI)
        from csmw[OF this] obtain lt 
          where lt: "lt  LT" and mw: "r1.must_wait s1 t lt (r1.deadlocked s1  r1.final_threads s1)" by blast
        have subset: "r1.deadlocked s1  r1.final_threads s1  r1.deadlocked s1  r2.deadlocked s2  r2.final_threads ?s2"
          by(auto dest: fin')
        from mw have "r2.must_wait ?s2 t lt (r1.deadlocked s1  r2.deadlocked ?s2  r2.final_threads ?s2)"
        proof(cases rule: r1.must_wait_elims)
          case lock thus ?thesis by(auto simp add: mbisim_eqs dest!: fin')
        next
          case (join t')
          from ‹r1.not_final_thread s1 t' obtain x1 ln
            where "thr s1 t' = (x1, ln)" by cases auto
          with mbisim obtain x2 where "ts2' t' = (x2, ln)" "t'  (x1, shr s1)  (x2, m2)" by(auto dest: mbisim_thrD1)
          show ?thesis
          proof(cases "wset s1 t' = None  ln = no_wait_locks")
            case False
            with ‹r1.not_final_thread s1 t' ‹thr s1 t' = (x1, ln) ts2' t' = (x2, ln) lt = Inr (Inl t') join
            show ?thesis by(auto simp add: mbisim_eqs r2.not_final_thread_iff r1.final_thread_def)
          next
            case True
            with ‹r1.not_final_thread s1 t' ‹thr s1 t' = (x1, ln) have "¬ final1 x1" by(cases) auto
            with join ‹thr s1 t' = (x1, ln) have "t'  r1.deadlocked s1" by(auto simp add: r1.final_thread_def)
            have "¬ final2 x2"
            proof
              assume "final2 x2"
              with final2_simulation[OF t'  (x1, shr s1)  (x2, m2)]
              obtain x1' m1' where "r1.silent_moves t' (x1, shr s1) (x1', m1')"
                and "t'  (x1', m1')  (x2, m2)" "final1 x1'" by auto
              from ‹r1.silent_moves t' (x1, shr s1) (x1', m1') have "x1' = x1"
              proof(cases rule: converse_rtranclpE2[consumes 1, case_names refl step])
                case (step x1'' m1'')
                from ‹r1.silent_move t' (x1, shr s1) (x1'', m1'')
                have "t'  (x1, shr s1) -1-ε (x1'', m1'')" by(auto dest: r1.silent_tl)
                hence "r1.redT s1 (t', ε) (redT_upd_ε s1 t' x1'' m1'')"
                  using ‹thr s1 t' = (x1, ln) True
                  by -(erule r1.redT_normal, auto simp add: redT_updLns_def redT_updWs_def finfun_Diag_const2 o_def)
                hence False using t'  r1.deadlocked s1 by(rule r1.red_no_deadlock)
                thus ?thesis ..
              qed simp
              with ¬ final1 x1 final1 x1' show False by simp
            qed
            thus ?thesis using ts2' t' = (x2, ln) join
              by(auto simp add: r2.not_final_thread_iff r1.final_thread_def)
          qed
        next
          case (interrupt t')
          have "r2.all_final_except ?s2 (r1.deadlocked s1  r2.deadlocked ?s2  r2.final_threads ?s2)"
          proof(rule r2.all_final_exceptI)
            fix t''
            assume "r2.not_final_thread ?s2 t''"
            then obtain x2 ln where "thr ?s2 t'' = (x2, ln)"
              and fin: "¬ final2 x2  ln  no_wait_locks  wset ?s2 t''  None"
              by(auto simp add: r2.not_final_thread_iff)
            from ‹thr ?s2 t'' = (x2, ln) mbisim
            obtain x1 where ts1t'': "thr s1 t'' = (x1, ln)" 
              and bisim'': "t''  (x1, shr s1)  (x2, shr ?s2)"
              by(auto dest: mbisim_thrD2)
            have "r1.not_final_thread s1 t''"
            proof(cases "wset ?s2 t'' = None  ln = no_wait_locks")
              case True
              with fin have "¬ final2 x2" by simp
              hence "¬ final1 x1"
              proof(rule contrapos_nn)
                assume "final1 x1"
                with final1_simulation[OF bisim'']
                obtain x2' m2' where τs2: "r2.silent_moves t'' (x2, shr ?s2) (x2', m2')"
                  and bisim''': "t''  (x1, shr s1)  (x2', m2')"
                  and "final2 x2'" by auto
                from τs2 have "x2' = x2"
                proof(cases rule: converse_rtranclpE2[consumes 1, case_names refl step])
                  case refl thus ?thesis by simp
                next
                  case (step x2'' m2'')
                  from True have "wset s1 t'' = None" "thr s1 t'' = (x1, no_wait_locks)" "ts2' t'' = (x2, no_wait_locks)"
                    using ts1t'' ‹thr ?s2 t'' = (x2, ln) mbisim by(simp_all add: mbisim_def)
                  hence no_τ2: "¬ r2.silent_move t'' (x2, m2) (x2'', m2'')"
                  proof(rule no_τ)
                    fix x1' m1'
                    assume "r1.silent_move t'' (x1, shr s1) (x1', m1')"
                    with final1 x1 show False by(auto dest: r1.final_no_red)
                  qed
                  with ‹r2.silent_move t'' (x2, shr ?s2) (x2'', m2'') have False by simp
                  thus ?thesis ..
                qed
                with final2 x2' show "final2 x2" by simp
              qed
              with ts1t'' show ?thesis ..
            next
              case False
              with ts1t'' mbisim show ?thesis by(auto simp add: r1.not_final_thread_iff mbisim_def)
            qed
            with ‹r1.all_final_except s1 (r1.deadlocked s1  r1.final_threads s1)
            have "t''  r1.deadlocked s1  r1.final_threads s1" by(rule r1.all_final_exceptD)
            thus "t''  r1.deadlocked s1  r2.deadlocked ?s2  r2.final_threads ?s2"
              by(auto dest: fin' simp add: mbisim_eqs)
          qed
          thus ?thesis using interrupt mbisim by(auto simp add: mbisim_def)
        qed
        hence "ltLT. r2.must_wait ?s2 t lt (r1.deadlocked s1  r2.deadlocked ?s2  r2.final_threads ?s2)"
          using lt  LT by blast }
      moreover from mbisim ‹wset s1 t = None› have "wset ?s2 t = None" by(simp add: mbisim_def)
      ultimately have ?Lock by simp
      thus ?thesis ..
    next
      case (wait x1 ln)
      from mbisim ‹thr s1 t = (x1, ln)
      obtain x2 where "ts2' t = (x2, ln)" by(auto dest: mbisim_thrD1)
      moreover
      have "r2.all_final_except ?s2 (r1.deadlocked s1)"
      proof(rule r2.all_final_exceptI)
        fix t
        assume "r2.not_final_thread ?s2 t"
        then obtain x2 ln where "ts2' t = (x2, ln)" by(auto simp add: r2.not_final_thread_iff)
        with mbisim obtain x1 where "thr s1 t = (x1, ln)" "t  (x1, shr s1)  (x2, m2)" by(auto dest: mbisim_thrD2)
        hence "r1.not_final_thread s1 t" using ‹r2.not_final_thread ?s2 t ts2' t = (x2, ln) mbisim fin'[of t]
          by(cases "wset s1 t")(auto simp add: r1.not_final_thread_iff r2.not_final_thread_iff mbisim_def r1.final_thread_def r2.final_thread_def)
        with ‹r1.all_final_except s1 (r1.deadlocked s1)
        show "t  r1.deadlocked s1" by(rule r1.all_final_exceptD)
      qed
      hence "r2.all_final_except ?s2 (r1.deadlocked s1  r2.deadlocked ?s2)"
        by(rule r2.all_final_except_mono') blast
      moreover
      from ‹waiting (wset s1 t) mbisim
      have "waiting (wset ?s2 t)" by(simp add: mbisim_def)
      ultimately have ?Wait by simp
      thus ?thesis by blast
    next
      case (acquire x1 ln l t')
      from mbisim ‹thr s1 t = (x1, ln)
      obtain x2 where "ts2' t = (x2, ln)" by(auto dest: mbisim_thrD1)
      moreover
      from t'  r1.deadlocked s1  r1.final_thread s1 t'
      have "(t'  r1.deadlocked s1  t'  r2.deadlocked ?s2)  r2.final_thread ?s2 t'" by(blast dest: fin')
      moreover
      from mbisim ‹has_lock (locks s1 $ l) t'
      have "has_lock (locks ?s2 $ l) t'" by(simp add: mbisim_def)
      ultimately have ?Acquire
        using 0 < ln $ l t  t' ¬ waiting (wset s1 t) mbisim
        by(auto simp add: mbisim_def)
      thus ?thesis by blast
    qed
  qed
  with red1 red2 mbisim show ?thesis by(blast intro: rtranclp_trans)
qed

lemma deadlocked2_imp_τs_deadlocked1:
  " s1 ≈m s2; t  r2.deadlocked s2 
   s1'. r1.mthr.silent_moves s1 s1'  t  r1.deadlocked s1'  s1' ≈m s2"
using FWdelay_bisimulation_diverge.deadlocked1_imp_τs_deadlocked2[OF FWdelay_bisimulation_diverge_flip]
unfolding flip_simps .

lemma deadlock1_imp_τs_deadlock2:
  assumes mbisim: "s1 ≈m s2"
  and dead: "r1.deadlock s1"
  shows "s2'. r2.mthr.silent_moves s2 s2'  r2.deadlock s2'  s1 ≈m s2'"
proof(cases "t. r1.not_final_thread s1 t")
  case True
  then obtain t where nfin: "r1.not_final_thread s1 t" ..
  from mfinal1_inv_simulation[OF mbisim]
  obtain ls2 ts2 m2 ws2 is2 where red1: "r2.mthr.silent_moves s2 (ls2, (ts2, m2), ws2, is2)"
    and "s1 ≈m (ls2, (ts2, m2), ws2, is2)" and "m2 = shr s2" 
    and fin: "t. r1.final_thread s1 t  r2.final_thread (ls2, (ts2, m2), ws2, is2) t" by fastforce
  from no_τMove1_τs_to_no_τMove2[OF s1 ≈m (ls2, (ts2, m2), ws2, is2)]
  obtain ts2' where red2: "r2.mthr.silent_moves (ls2, (ts2, m2), ws2, is2) (ls2, (ts2', m2), ws2, is2)"
    and no_τ: "t x1 x2 x2' m2'.  wset s1 t = None; thr s1 t = (x1, no_wait_locks); ts2' t = (x2, no_wait_locks);
                           x' m'. r1.silent_move t (x1, shr s1) (x', m')  False 
                ¬ r2.silent_move t (x2, m2) (x2', m2')"
    and mbisim: "s1 ≈m (ls2, (ts2', m2), ws2, is2)" by fastforce
  from mbisim have mbisim_eqs: "ls2 = locks s1" "ws2 = wset s1" "is2 = interrupts s1"
    by(simp_all add: mbisim_def)
  let ?s2 = "(ls2, (ts2', m2), ws2, is2)"
  from red2 have fin': "t. r1.final_thread s1 t  r2.final_thread ?s2 t"
    by(rule r2.τmRedT_preserves_final_thread)(rule fin)
  have "r2.deadlock ?s2"
  proof(rule r2.deadlockI, goal_cases)
    case (1 t x2)
    note ts2t = ‹thr ?s2 t = (x2, no_wait_locks)
    with mbisim obtain x1 where ts1t: "thr s1 t = (x1, no_wait_locks)"
      and bisim: "t  (x1, shr s1)  (x2, m2)" by(auto dest: mbisim_thrD2)
    from ‹wset ?s2 t = None› mbisim have ws1t: "wset s1 t = None" by(simp add: mbisim_def)
    have "¬ final1 x1"
    proof
      assume "final1 x1"
      with ts1t ws1t have "r1.final_thread s1 t" by(simp add: r1.final_thread_def)
      hence "r2.final_thread ?s2 t" by(rule fin')
      with ¬ final2 x2 ts2t ‹wset ?s2 t = None› show False by(simp add: r2.final_thread_def)
    qed
    from r1.deadlockD1[OF dead ts1t this ‹wset s1 t = None›]
    have ms: "r1.must_sync t x1 (shr s1)"
      and csmw: "LT. r1.can_sync t x1 (shr s1) LT  ltLT. r1.must_wait s1 t lt (dom (thr s1))"
      by blast+
    {
      from ‹r1.must_sync t x1 (shr s1) obtain ta1 x1' m1'
        where r1: "t  (x1, shr s1) -1-ta1 (x1', m1')"
        and s1': "s1'. r1.actions_ok s1' t ta1" by(fastforce elim: r1.must_syncE)
      have "¬ τmove1 (x1, shr s1) ta1 (x1', m1')" (is "¬ ")
      proof
        assume ""
        hence "ta1 = ε" by(rule r1.silent_tl)
        with r1 have "r1.can_sync t x1 (shr s1) {}"
          by(auto intro!: r1.can_syncI simp add: collect_locks_def collect_interrupts_def)
        from csmw[OF this] show False by blast
      qed
      from simulation1[OF bisim r1 this]
      obtain x2' m2' x2'' m2'' ta2 where r2: "r2.silent_moves t (x2, m2) (x2', m2')"
        and r2': "t  (x2', m2') -2-ta2  (x2'', m2'')"
        and bisim': "t  (x1', m1')  (x2'', m2'')" and tasim: "ta1 ∼m ta2" by auto
      from r2
      have "ta2 x2' m2' s2'. t  (x2, m2) -2-ta2 (x2', m2')  r2.actions_ok s2' t ta2"
      proof(cases rule: converse_rtranclpE2[consumes 1, case_names base step])
        case base
        from r2'[folded base] s1'[unfolded ex_actions_ok1_conv_ex_actions_ok2[OF tasim]]
        show ?thesis by blast
      next
        case (step x2''' m2''')
        hence "t  (x2, m2) -2-ε (x2''', m2''')" by(auto dest: r2.silent_tl)
        moreover have "r2.actions_ok (undefined, (undefined, undefined), Map.empty, undefined) t ε" by auto
        ultimately show ?thesis by-(rule exI conjI|assumption)+
      qed
      hence "r2.must_sync t x2 m2" unfolding r2.must_sync_def2 . }
    moreover
    { fix LT
      assume "r2.can_sync t x2 m2 LT"
      then obtain ta2 x2' m2' where r2: "t  (x2, m2) -2-ta2 (x2', m2')"
        and LT: "LT = collect_locks ta2l <+> collect_cond_actions ta2c <+> collect_interrupts ta2i"
        by(auto elim: r2.can_syncE)
      from ts2t have "ts2' t = (x2, no_wait_locks)" by simp
      with ws1t ts1t have "¬ r2.silent_move t (x2, m2) (x2', m2')"
      proof(rule no_τ)
        fix x1' m1'
        assume "r1.silent_move t (x1, shr s1) (x1', m1')"
        hence "t  (x1, shr s1) -1-ε (x1', m1')" by(auto dest: r1.silent_tl)
        hence "r1.can_sync t x1 (shr s1) {}"
          by(auto intro: r1.can_syncI simp add: collect_locks_def collect_interrupts_def)
        with csmw[OF this] show False by blast
      qed
      with r2 have "¬ τmove2 (x2, m2) ta2 (x2', m2')" by auto
      from simulation2[OF bisim r2 this] obtain x1' m1' x1'' m1'' ta1
        where τr1: "r1.silent_moves t (x1, shr s1) (x1', m1')"
        and r1: "t  (x1', m1') -1-ta1 (x1'', m1'')"
        and nτ1: "¬ τmove1 (x1', m1') ta1 (x1'', m1'')"
        and bisim': "t  (x1'', m1'')  (x2', m2')"
        and tlsim: "ta1 ∼m ta2" by auto
      from τr1 obtain [simp]: "x1' = x1" "m1' = shr s1"
      proof(cases rule: converse_rtranclpE2[consumes 1, case_names refl step])
        case (step X M)
        from ‹r1.silent_move t (x1, shr s1) (X, M)
        have "t  (x1, shr s1) -1-ε (X, M)" by(auto dest: r1.silent_tl)
        hence "r1.can_sync t x1 (shr s1) {}"
          by(auto intro: r1.can_syncI simp add: collect_locks_def collect_interrupts_def)
        with csmw[OF this] have False by blast
        thus ?thesis ..
      qed blast
      from tlsim LT have "LT = collect_locks ta1l <+> collect_cond_actions ta1c <+> collect_interrupts ta1i"
        by(auto simp add: ta_bisim_def)
      with r1 have "r1.can_sync t x1 (shr s1) LT" by(auto intro: r1.can_syncI)
      from csmw[OF this] obtain lt 
        where lt: "lt  LT" "r1.must_wait s1 t lt (dom (thr s1))" by blast
      from ‹r1.must_wait s1 t lt (dom (thr s1)) have "r2.must_wait ?s2 t lt (dom (thr ?s2))"
      proof(cases rule: r1.must_wait_elims)
        case (lock l)
        with mbisim_dom_eq[OF mbisim] show ?thesis by(auto simp add: mbisim_eqs)
      next
        case (join t')
        from dead deadlock_mbisim_not_final_thread_pres[OF _ ‹r1.not_final_thread s1 t' fin' mbisim]
        have "r2.not_final_thread ?s2 t'" by auto
        thus ?thesis using join mbisim_dom_eq[OF mbisim] by auto
      next
        case (interrupt t')
        have "r2.all_final_except ?s2 (dom (thr ?s2))" by(auto intro!: r2.all_final_exceptI)
        with interrupt show ?thesis by(auto simp add: mbisim_eqs)
      qed
      with lt have "ltLT. r2.must_wait ?s2 t lt (dom (thr ?s2))" by blast }
    ultimately show ?case by fastforce
  next
    case (2 t x2 ln l)
    note dead moreover
    from mbisim ‹thr ?s2 t = (x2, ln)
    obtain x1 where "thr s1 t = (x1, ln)" by(auto dest: mbisim_thrD2)
    moreover note 0 < ln $ l
    moreover from ¬ waiting (wset ?s2 t) mbisim
    have "¬ waiting (wset s1 t)" by(simp add: mbisim_def)
    ultimately obtain l' t' where "0 < ln $ l'" "t  t'" "thr s1 t'  None" "has_lock (locks s1 $ l') t'"
      by(rule r1.deadlockD2)
    thus ?case using mbisim_thrNone_eq[OF mbisim, of t'] mbisim by(auto simp add: mbisim_def)
  next
    case (3 t x2 w)
    from mbisim_thrD2[OF mbisim this]
    obtain x1 where "thr s1 t = (x1, no_wait_locks)" by auto
    with dead have "wset s1 t  PostWS w" by(rule r1.deadlockD3[rule_format])
    with mbisim show ?case by(simp add: mbisim_def)
  qed
  with red1 red2 mbisim show ?thesis by(blast intro: rtranclp_trans)
next
  case False
  hence "r1.mfinal s1" by(auto intro: r1.mfinalI simp add: r1.not_final_thread_iff)
  from mfinal1_simulation[OF mbisim this]
  obtain s2' where "τmRed2 s2 s2'" "s1 ≈m s2'" "r2.mfinal s2'" "shr s2' = shr s2" by blast
  thus ?thesis by(blast intro: r2.mfinal_deadlock)
qed

lemma deadlock2_imp_τs_deadlock1:
  " s1 ≈m s2; r2.deadlock s2 
   s1'. r1.mthr.silent_moves s1 s1'  r1.deadlock s1'  s1' ≈m s2"
using FWdelay_bisimulation_diverge.deadlock1_imp_τs_deadlock2[OF FWdelay_bisimulation_diverge_flip]
unfolding flip_simps .

lemma deadlocked'1_imp_τs_deadlocked'2:
  " s1 ≈m s2; r1.deadlocked' s1 
   s2'. r2.mthr.silent_moves s2 s2'  r2.deadlocked' s2'  s1 ≈m s2'"
unfolding r1.deadlock_eq_deadlocked'[symmetric] r2.deadlock_eq_deadlocked'[symmetric]
by(rule deadlock1_imp_τs_deadlock2)

lemma deadlocked'2_imp_τs_deadlocked'1:
  " s1 ≈m s2; r2.deadlocked' s2   s1'. r1.mthr.silent_moves s1 s1'  r1.deadlocked' s1'  s1' ≈m s2"
unfolding r1.deadlock_eq_deadlocked'[symmetric] r2.deadlock_eq_deadlocked'[symmetric]
by(rule deadlock2_imp_τs_deadlock1)

end

context FWbisimulation begin

lemma mbisim_final_thread_preserve1:
  assumes mbisim: "s1 ≈m s2" and fin: "r1.final_thread s1 t"
  shows "r2.final_thread s2 t"
proof -
  from fin obtain x1 where ts1t: "thr s1 t = (x1, no_wait_locks)"
    and fin1: "final1 x1" and ws1t: "wset s1 t = None"
    by(auto elim: r1.final_threadE)
  from mbisim ts1t obtain x2 
    where ts2t: "thr s2 t = (x2, no_wait_locks)"
    and bisim: "t  (x1, shr s1)  (x2, shr s2)" by(auto dest: mbisim_thrD1)
  note ts2t moreover from fin1 bisim have "final2 x2" by(auto dest: bisim_final)
  moreover from mbisim ws1t have "wset s2 t = None" by(simp add: mbisim_def)
  ultimately show ?thesis by(rule r2.final_threadI)
qed

lemma mbisim_final_thread_preserve2:
  " s1 ≈m s2; r2.final_thread s2 t   r1.final_thread s1 t"
using FWbisimulation.mbisim_final_thread_preserve1[OF FWbisimulation_flip]
unfolding flip_simps .

lemma mbisim_final_thread_inv:
  "s1 ≈m s2  r1.final_thread s1 t  r2.final_thread s2 t"
by(blast intro: mbisim_final_thread_preserve1 mbisim_final_thread_preserve2)

lemma mbisim_not_final_thread_inv:
  assumes bisim: "mbisim s1 s2"
  shows "r1.not_final_thread s1 = r2.not_final_thread s2"
proof(rule ext)
  fix t
  show "r1.not_final_thread s1 t = r2.not_final_thread s2 t"
  proof(cases "thr s1 t")
    case None
    with mbisim_thrNone_eq[OF bisim, of t] have "thr s2 t = None" by simp
    with None show ?thesis
      by(auto elim!: r2.not_final_thread.cases r1.not_final_thread.cases
             intro: r2.not_final_thread.intros r1.not_final_thread.intros)
  next
    case (Some a)
    then obtain x1 ln where tst1: "thr s1 t = (x1, ln)" by(cases a) auto
    from mbisim_thrD1[OF bisim tst1] obtain x2
      where tst2: "thr s2 t = (x2, ln)" and bisimt: "t  (x1, shr s1)  (x2, shr s2)" by blast
    from bisim have "wset s2 = wset s1" by(simp add: mbisim_def)
    with tst2 tst1 bisim_final[OF bisimt] show ?thesis
      by(simp add: r1.not_final_thread_conv r2.not_final_thread_conv)(rule mbisim_final_thread_inv[OF bisim])
  qed
qed

lemma mbisim_deadlocked_preserve1:
  assumes mbisim: "s1 ≈m s2" and dead: "t  r1.deadlocked s1"
  shows "t  r2.deadlocked s2"
proof -
  from deadlocked1_imp_τs_deadlocked2[OF mbisim dead]
  obtain s2' where "r2.mthr.silent_moves s2 s2'"
    and "t  r2.deadlocked s2'" by blast
  from ‹r2.mthr.silent_moves s2 s2' have "s2' = s2"
    by(rule converse_rtranclpE)(auto elim: r2.mτmove.cases)
  with t  r2.deadlocked s2' show ?thesis by simp
qed

lemma mbisim_deadlocked_preserve2:
  " s1 ≈m s2; t  r2.deadlocked s2   t  r1.deadlocked s1"
using FWbisimulation.mbisim_deadlocked_preserve1[OF FWbisimulation_flip]
unfolding flip_simps .

lemma mbisim_deadlocked_inv:
  "s1 ≈m s2  r1.deadlocked s1 = r2.deadlocked s2"
by(blast intro!: mbisim_deadlocked_preserve1 mbisim_deadlocked_preserve2)

lemma mbisim_deadlocked'_inv:
  "s1 ≈m s2  r1.deadlocked' s1  r2.deadlocked' s2"
unfolding r1.deadlocked'_def r2.deadlocked'_def
by(simp add: mbisim_not_final_thread_inv mbisim_deadlocked_inv)

lemma mbisim_deadlock_inv:
  "s1 ≈m s2  r1.deadlock s1 = r2.deadlock s2"
unfolding r1.deadlock_eq_deadlocked' r2.deadlock_eq_deadlocked'
by(rule mbisim_deadlocked'_inv)

end

(* Nice to have, but not needed any more *)

context FWbisimulation begin

lemma bisim_can_sync_preserve1:
  assumes bisim: "t  (x1, m1)  (x2, m2)" and cs: "t  x1, m1 LT ≀1"
  shows "t  x2, m2 LT ≀2"
proof -
  from cs obtain ta1 x1' m1' where red1: "t  (x1, m1) -1-ta1 (x1', m1')"
    and LT: "LT = collect_locks ta1l <+> collect_cond_actions ta1c <+> collect_interrupts ta1i" by(rule r1.can_syncE)
  from bisimulation.simulation1[OF bisimulation_axioms, OF bisim red1] obtain x2' ta2 m2'
    where red2: "t  (x2, m2) -2-ta2 (x2', m2')" 
    and tasim: "ta1 ∼m ta2" by fastforce
  from tasim LT have "LT = collect_locks ta2l <+> collect_cond_actions ta2c <+> collect_interrupts ta2i"
    by(auto simp add: ta_bisim_def)
  with red2 show ?thesis by(rule r2.can_syncI)
qed

lemma bisim_can_sync_preserve2:
  " t  (x1, m1)  (x2, m2); t  x2, m2 LT ≀2   t  x1, m1 LT ≀1"
using FWbisimulation.bisim_can_sync_preserve1[OF FWbisimulation_flip]
unfolding flip_simps .

lemma bisim_can_sync_inv:
  "t  (x1, m1)  (x2, m2)  t  x1, m1 LT ≀1  t  x2, m2 LT ≀2"
by(blast intro: bisim_can_sync_preserve1 bisim_can_sync_preserve2)

lemma bisim_must_sync_preserve1:
  assumes bisim: "t  (x1, m1)  (x2, m2)" and ms: "t  x1, m1 ≀1"
  shows "t  x2, m2 ≀2"
proof -
  from ms obtain ta1 x1' m1' where red1: "t  (x1, m1) -1-ta1 (x1', m1')"
    and s1': "s1'. r1.actions_ok s1' t ta1" by(fastforce elim: r1.must_syncE)
  from bisimulation.simulation1[OF bisimulation_axioms, OF bisim red1] obtain x2' ta2 m2'
    where red2: "t  (x2, m2) -2-ta2 (x2', m2')" 
    and tasim: "ta1 ∼m ta2" by fastforce
  from ex_actions_ok1_conv_ex_actions_ok2[OF tasim, of t] s1' red2
  show ?thesis unfolding r2.must_sync_def2 by blast
qed

lemma bisim_must_sync_preserve2:
  " t  (x1, m1)  (x2, m2); t  x2, m2 ≀2   t  x1, m1 ≀1"
using FWbisimulation.bisim_must_sync_preserve1[OF FWbisimulation_flip]
unfolding flip_simps .

lemma bisim_must_sync_inv:
  "t  (x1, m1)  (x2, m2)  t  x1, m1 ≀1  t  x2, m2 ≀2"
by(blast intro: bisim_must_sync_preserve1 bisim_must_sync_preserve2)

end

end

Theory FWLiftingSem

(*  Title:      JinjaThreads/Framework/FWLiftingSem.thy
    Author:     Andreas Lochbihler
*)

section ‹Semantic properties of lifted predicates›

theory FWLiftingSem
imports
  FWSemantics
  FWLifting
begin

context multithreaded_base begin

lemma redT_preserves_ts_inv_ok:
  " s -tta s'; ts_inv_ok (thr s) I 
   ts_inv_ok (thr s') (upd_invs I P tat)"
by(erule redT.cases)(fastforce intro: ts_inv_ok_upd_invs ts_inv_ok_upd_ts redT_updTs_Some)+

lemma RedT_preserves_ts_inv_ok:
  " s -▹ttas→* s'; ts_inv_ok (thr s) I 
   ts_inv_ok (thr s') (upd_invs I Q (concat (map (thr_a  snd) ttas)))"
by(induct rule: RedT_induct)(auto intro: redT_preserves_ts_inv_ok)

lemma redT_upd_inv_ext:
  fixes I :: "'t  'i"
  shows " s -tta s'; ts_inv_ok (thr s) I   I m upd_invs I P tat"
by(erule redT.cases, auto intro: ts_inv_ok_inv_ext_upd_invs)

lemma RedT_upd_inv_ext:
  fixes I :: "'t  'i"
  shows " s -▹ttas→* s'; ts_inv_ok (thr s) I 
          I m upd_invs I P (concat (map (thr_a  snd) ttas))"
proof(induct rule: RedT_induct)
  case refl thus ?case by simp
next
  case (step S TTAS S' T TA S'')
  hence "ts_inv_ok (thr S') (upd_invs I P (concat (map (thr_a  snd) TTAS)))"
    by -(rule RedT_preserves_ts_inv_ok)
  hence "upd_invs I P (concat (map (thr_a  snd) TTAS)) m upd_invs (upd_invs I P (concat (map (thr_a  snd) TTAS))) P TAt" 
    using step by -(rule redT_upd_inv_ext)
  with step show ?case by(auto elim!: map_le_trans simp add: comp_def)
qed

end

locale lifting_inv = multithreaded final r convert_RA
  for final :: "'x  bool" 
  and r :: "('l,'t,'x,'m,'w,'o) semantics" ("_  _ -_ _" [50,0,0,50] 80) 
  and convert_RA :: "'l released_locks  'o list"
  +
  fixes P :: "'i  't  'x  'm  bool"
  assumes invariant_red: " t  x, m -ta x', m'; P i t x m   P i t x' m'"
  and invariant_NewThread: " t  x, m -ta x', m'; P i t x m; NewThread t'' x'' m'  set tat  
                             i''. P i'' t'' x'' m'"
  and invariant_other: " t  x, m -ta x', m'; P i t x m; P i'' t'' x'' m   P i'' t'' x'' m'"
begin

lemma redT_updTs_invariant:
  fixes ln
  assumes tsiP: "ts_inv P I ts m"
  and red: "t  x, m -ta x', m'"
  and tao: "thread_oks ts tat"
  and tst: "ts t = (x, ln)"
  shows "ts_inv P (upd_invs I P tat) (redT_updTs ts tat(t  (x', ln'))) m'"
proof(rule ts_invI)
  fix T X LN
  assume XLN: "(redT_updTs ts tat(t  (x', ln'))) T = (X, LN)"
  from tsiP ts t = (x, ln) obtain i where "I t = i" "P i t x m" 
    by(auto dest: ts_invD)
  show "i. upd_invs I P tat T = i  P i T X m'"
  proof(cases "T = t")
    case True
    from red P i t x m have "P i t x' m'" by(rule invariant_red)
    moreover from I t = i ts t = (x, ln) tao 
    have "upd_invs I P tat t = i"
      by(simp add: upd_invs_Some)
    ultimately show ?thesis using True XLN by simp
  next
    case False
    show ?thesis
    proof(cases "ts T")
      case None
      with XLN tao False have "m'. NewThread T X m'  set tat"
        by(auto dest: redT_updTs_new_thread)
      with red have nt: "NewThread T X m'  set tat" by(auto dest: new_thread_memory)
      with red P i t x m have "i''. P i'' T X m'" by(rule invariant_NewThread)
      hence "P (SOME i. P i T X m') T X m'" by(rule someI_ex)
      with nt tao show ?thesis by(auto intro: SOME_new_thread_upd_invs) 
    next
      case (Some a)
      obtain X' LN' where [simp]: "a = (X', LN')" by(cases a)
      with ts T = a have esT: "ts T = (X', LN')" by simp
      hence "redT_updTs ts tat T = (X', LN')"
        using ‹thread_oks ts tat by(auto intro: redT_updTs_Some)
      moreover from esT tsiP obtain i' where "I T = i'" "P i' T X' m"
        by(auto dest: ts_invD)
      from red P i t x m P i' T X' m
      have "P i' T X' m'" by(rule invariant_other)
      moreover from I T = i' esT tao have "upd_invs I P tat T = i'"
        by(simp add: upd_invs_Some)
      ultimately show ?thesis using XLN False by simp
    qed
  qed
qed

theorem redT_invariant:
  assumes redT: "s -tta s'"
  and esinvP: "ts_inv P I (thr s) (shr s)"
  shows "ts_inv P (upd_invs I P tat) (thr s') (shr s')"
using redT
proof(cases rule: redT_elims)
  case acquire thus ?thesis using esinvP 
    by(auto intro!: ts_invI split: if_split_asm dest: ts_invD)
next
  case (normal x x' m')
  with esinvP
  have "ts_inv P (upd_invs I P tat) (redT_updTs (thr s) tat(t  (x', redT_updLns (locks s) t no_wait_locks tal))) m'"
    by(auto intro: redT_updTs_invariant)
  thus ?thesis using normal by simp
qed

theorem RedT_invariant:
  assumes RedT: "s -▹ttas→* s'"
  and esinvQ: "ts_inv P I (thr s) (shr s)"
  shows "ts_inv P (upd_invs I P (concat (map (thr_a  snd) ttas))) (thr s') (shr s')"
using RedT esinvQ
proof(induct rule: RedT_induct)
  case refl thus ?case by(simp (no_asm))
next
  case (step S TTAS S' T TA S'')
  note IH = ‹ts_inv P I (thr S) (shr S)  ts_inv P (upd_invs I P (concat (map (thr_a  snd) TTAS))) (thr S') (shr S')
  with ‹ts_inv P I (thr S) (shr S)
  have "ts_inv P (upd_invs I P (concat (map (thr_a  snd) TTAS))) (thr S') (shr S')" by blast
  with S' -TTA S'' 
  have "ts_inv P (upd_invs (upd_invs I P (concat (map (thr_a  snd) TTAS))) P TAt) (thr S'') (shr S'')"
    by(rule redT_invariant)
  thus ?case by(simp add: comp_def)
qed

lemma invariant3p_ts_inv: "invariant3p redT {s. I. ts_inv P I (thr s) (shr s)}"
by(auto intro!: invariant3pI dest: redT_invariant)

end

locale lifting_wf = multithreaded final r convert_RA
  for final :: "'x  bool" 
  and r :: "('l,'t,'x,'m,'w,'o) semantics" ("_  _ -_ _" [50,0,0,50] 80) 
  and convert_RA :: "'l released_locks  'o list"
  +
  fixes P :: "'t  'x  'm  bool"
  assumes preserves_red: " t  x, m -ta x', m'; P t x m   P t x' m'"
  and preserves_NewThread: " t  x, m -ta x', m'; P t x m; NewThread t'' x'' m'  set tat  
                             P t'' x'' m'"
  and preserves_other: " t  x, m -ta x', m'; P t x m; P t'' x'' m   P t'' x'' m'"
begin

lemma lifting_inv: "lifting_inv final r (λ_ :: unit. P)"
by(unfold_locales)(blast intro: preserves_red preserves_NewThread preserves_other)+

lemma redT_updTs_preserves:
  fixes ln
  assumes esokQ: "ts_ok P ts m"
  and red: "t  x, m -ta x', m'"
  and "ts t = (x, ln)"
  and "thread_oks ts tat"
  shows "ts_ok P (redT_updTs ts tat(t  (x', ln'))) m'"
proof -
  interpret lifting_inv final r convert_RA "λ_ :: unit. P" by(rule lifting_inv)
  from esokQ obtain I :: "'t  unit" where "ts_inv (λ_. P) I ts m" by(rule ts_ok_into_ts_inv_const)
  hence "ts_inv (λ_. P) (upd_invs I (λ_. P) tat) (redT_updTs ts tat(t  (x', ln'))) m'"
    using red ‹thread_oks ts tat ts t = (x, ln) by(rule redT_updTs_invariant)
  thus ?thesis by(rule ts_inv_const_into_ts_ok)
qed

theorem redT_preserves:
  assumes redT: "s -tta s'"
  and esokQ: "ts_ok P (thr s) (shr s)"
  shows "ts_ok P (thr s') (shr s')"
proof -
  interpret lifting_inv final r convert_RA "λ_ :: unit. P" by(rule lifting_inv)
  from esokQ obtain I :: "'t  unit" where "ts_inv (λ_. P) I (thr s) (shr s)" by(rule ts_ok_into_ts_inv_const)
  with redT have "ts_inv (λ_. P) (upd_invs I (λ_. P) tat) (thr s') (shr s')" by(rule redT_invariant)
  thus ?thesis by(rule ts_inv_const_into_ts_ok)
qed

theorem RedT_preserves:
  " s -▹ttas→* s'; ts_ok P (thr s) (shr s)   ts_ok P (thr s') (shr s')"
by(erule (1) RedT_lift_preserveD)(fastforce elim: redT_preserves)

lemma invariant3p_ts_ok: "invariant3p redT {s. ts_ok P (thr s) (shr s)}"
by(auto intro!: invariant3pI intro: redT_preserves)

end

lemma lifting_wf_Const [intro!]: 
  assumes "multithreaded final r"
  shows "lifting_wf final r (λt x m. k)"
proof -
  interpret multithreaded final r using assms .
  show ?thesis by unfold_locales blast+
qed

end

Theory FWInitFinLift

(*  Title:      JinjaThreads/MM/FWInitFinLift.thy
    Author:     Andreas Lochbihler
*)

section ‹Synthetic first and last actions for each thread›

theory FWInitFinLift
imports
  FWLTS
  FWLiftingSem
begin

datatype status = 
  PreStart
| Running
| Finished

abbreviation convert_TA_initial :: "('l,'t,'x,'m,'w,'o) thread_action  ('l,'t,status × 'x,'m,'w,'o) thread_action"
where "convert_TA_initial == convert_extTA (Pair PreStart)"

lemma convert_obs_initial_convert_TA_initial: 
  "convert_obs_initial (convert_TA_initial ta) = convert_TA_initial (convert_obs_initial ta)"
by(simp add: convert_obs_initial_def)

lemma convert_TA_initial_inject [simp]:
  "convert_TA_initial ta = convert_TA_initial ta'  ta = ta'"
by(cases ta)(cases ta', auto)

context final_thread begin

primrec init_fin_final :: "status × 'x  bool"
where "init_fin_final (status, x)  status = Finished  final x"

end

context multithreaded_base begin

inductive init_fin :: "('l,'t,status × 'x,'m,'w,'o action) semantics" ("_  _ -_→i _" [50,0,0,51] 51)
where
  NormalAction:
  "t  x, m -ta x', m' 
   t  ((Running, x), m) -convert_TA_initial (convert_obs_initial ta)→i ((Running, x'), m')"

| InitialThreadAction:
  "t  ((PreStart, x), m) -InitialThreadAction→i ((Running, x), m)"

| ThreadFinishAction:
  "final x  t  ((Running, x), m) -ThreadFinishAction→i ((Finished, x), m)"

end

declare split_paired_Ex [simp del]

inductive_simps (in multithreaded_base) init_fin_simps [simp]:
  "t  ((Finished, x), m) -ta→i xm'"
  "t  ((PreStart, x), m) -ta→i xm'"
  "t  ((Running, x), m) -ta→i xm'"
  "t  xm -ta→i ((Finished, x'), m')"
  "t  xm -ta→i ((Running, x'), m')"
  "t  xm -ta→i ((PreStart, x'), m')"

declare split_paired_Ex [simp]

context multithreaded begin

lemma multithreaded_init_fin: "multithreaded init_fin_final init_fin"
by(unfold_locales)(fastforce simp add: init_fin.simps convert_obs_initial_def ta_upd_simps dest: new_thread_memory)+

end

locale if_multithreaded_base = multithreaded_base +
  constrains final :: "'x  bool" 
  and r :: "('l,'t,'x,'m,'w,'o) semantics" 
  and convert_RA :: "'l released_locks  'o list"

sublocale if_multithreaded_base < "if": multithreaded_base
  "init_fin_final"
  "init_fin"
  "map NormalAction  convert_RA"
.

locale if_multithreaded = if_multithreaded_base + multithreaded +
  constrains final :: "'x  bool" 
  and r :: "('l,'t,'x,'m,'w,'o) semantics" 
  and convert_RA :: "'l released_locks  'o list"

sublocale if_multithreaded < "if": multithreaded
  "init_fin_final"
  "init_fin"
  "map NormalAction  convert_RA"
by(rule multithreaded_init_fin)

context τmultithreaded begin

inductive init_fin_τmove :: "('l,'t,status × 'x,'m,'w,'o action) τmoves"
where
  "τmove (x, m) ta (x', m') 
   init_fin_τmove ((Running, x), m) (convert_TA_initial (convert_obs_initial ta)) ((Running, x'), m')"

lemma init_fin_τmove_simps [simp]:
  "init_fin_τmove ((PreStart, x), m) ta x'm' = False"
  "init_fin_τmove xm ta ((PreStart, x'), m') = False"
  "init_fin_τmove ((Running, x), m) ta ((s, x'), m') 
   (ta'. ta = convert_TA_initial (convert_obs_initial ta')  s = Running  τmove (x, m) ta' (x', m'))"
  "init_fin_τmove ((s, x), m) ta ((Running, x'), m')  
   s = Running  (ta'. ta = convert_TA_initial (convert_obs_initial ta')  τmove (x, m) ta' (x', m'))"
  "init_fin_τmove ((Finished, x), m) ta x'm' = False"
  "init_fin_τmove xm ta ((Finished, x'), m') = False"
by(simp_all add: init_fin_τmove.simps)

lemma init_fin_silent_move_RunningI:
  assumes "silent_move t (x, m) (x', m')"
  shows "τtrsys.silent_move (init_fin t) init_fin_τmove ((Running, x), m) ((Running, x'), m')"
using assms by(cases)(auto intro: τtrsys.silent_move.intros init_fin.NormalAction)

lemma init_fin_silent_moves_RunningI:
  assumes "silent_moves t (x, m) (x', m')"
  shows "τtrsys.silent_moves (init_fin t) init_fin_τmove ((Running, x), m) ((Running, x'), m')"
using assms
by(induct rule: rtranclp_induct2)(auto elim: rtranclp.rtrancl_into_rtrancl intro: init_fin_silent_move_RunningI)

lemma init_fin_silent_moveD:
  assumes "τtrsys.silent_move (init_fin t) init_fin_τmove ((s, x), m) ((s', x'), m')"
  shows "silent_move t (x, m) (x', m')  s = s'  s' = Running"
using assms by(auto elim!: τtrsys.silent_move.cases init_fin.cases)

lemma init_fin_silent_movesD:
  assumes "τtrsys.silent_moves (init_fin t) init_fin_τmove ((s, x), m) ((s', x'), m')"
  shows "silent_moves t (x, m) (x', m')  s = s'"
using assms
by(induct "((s, x), m)" "((s', x'), m')" arbitrary: s' x' m')
  (auto 7 2 simp only: dest!: init_fin_silent_moveD intro: rtranclp.rtrancl_into_rtrancl)

lemma init_fin_τdivergeD:
  assumes "τtrsys.τdiverge (init_fin t) init_fin_τmove ((status, x), m)"
  shows "τdiverge t (x, m)  status = Running"
proof
  from assms show "status = Running"
    by(cases rule: τtrsys.τdiverge.cases[consumes 1])(auto dest: init_fin_silent_moveD)
  moreover define xm where "xm = (x, m)"
  ultimately have "x m. xm = (x, m)  τtrsys.τdiverge (init_fin t) init_fin_τmove ((Running, x), m)"
    using assms by blast
  thus "τdiverge t xm"
  proof(coinduct)
    case (τdiverge xm)
    then obtain x m 
      where diverge: "τtrsys.τdiverge (init_fin t) init_fin_τmove ((Running, x), m)" 
      and xm: "xm = (x, m)" by blast
    thus ?case
      by(cases rule:τtrsys.τdiverge.cases[consumes 1])(auto dest!: init_fin_silent_moveD)
  qed
qed

lemma init_fin_τdiverge_RunningI:
  assumes "τdiverge t (x, m)"
  shows "τtrsys.τdiverge (init_fin t) init_fin_τmove ((Running, x), m)"
proof -
  define sxm where "sxm = ((Running, x), m)"
  with assms have "x m. τdiverge t (x, m)  sxm = ((Running, x), m)" by blast
  thus "τtrsys.τdiverge (init_fin t) init_fin_τmove sxm"
  proof(coinduct rule: τtrsys.τdiverge.coinduct[consumes 1, case_names τdiverge])
    case (τdiverge sxm)
    then obtain x m where "τdiverge t (x, m)" and "sxm = ((Running, x), m)" by blast
    thus ?case by(cases)(auto intro: init_fin_silent_move_RunningI)
  qed
qed

lemma init_fin_τdiverge_conv:
  "τtrsys.τdiverge (init_fin t) init_fin_τmove ((status, x), m) 
   τdiverge t (x, m)  status = Running"
by(blast intro: init_fin_τdiverge_RunningI dest: init_fin_τdivergeD)

end

lemma init_fin_τmoves_False:
  "τmultithreaded.init_fin_τmove (λ_ _ _. False) = (λ_ _ _. False)"
by(simp add: fun_eq_iff τmultithreaded.init_fin_τmove.simps)

locale if_τmultithreaded = if_multithreaded_base + τmultithreaded +
  constrains final :: "'x  bool" 
  and r :: "('l,'t,'x,'m,'w,'o) semantics" 
  and convert_RA :: "'l released_locks  'o list"
  and τmove :: "('l,'t,'x,'m,'w,'o) τmoves"

sublocale if_τmultithreaded < "if": τmultithreaded
  "init_fin_final"
  "init_fin"
  "map NormalAction  convert_RA"
  "init_fin_τmove"
.

locale if_τmultithreaded_wf = if_multithreaded_base + τmultithreaded_wf +
  constrains final :: "'x  bool" 
  and r :: "('l,'t,'x,'m,'w,'o) semantics" 
  and convert_RA :: "'l released_locks  'o list"
  and τmove :: "('l,'t,'x,'m,'w,'o) τmoves"

sublocale if_τmultithreaded_wf < if_multithreaded
by unfold_locales

sublocale if_τmultithreaded_wf < if_τmultithreaded .

context τmultithreaded_wf begin

lemma τmultithreaded_wf_init_fin:
  "τmultithreaded_wf init_fin_final init_fin init_fin_τmove"
proof -
  interpret "if": multithreaded init_fin_final init_fin "map NormalAction  convert_RA"
    by(rule multithreaded_init_fin)
  show ?thesis
  proof(unfold_locales)
    fix t x m ta x' m'
    assume "init_fin_τmove (x, m) ta (x', m')" "t  (x, m) -ta→i (x', m')" 
    thus "m = m'" by(cases)(auto dest: τmove_heap)
  next
    fix s ta s'
    assume "init_fin_τmove s ta s'"
    thus "ta = ε" by(cases)(auto dest: silent_tl)
  qed
qed

end

sublocale if_τmultithreaded_wf < "if": τmultithreaded_wf
  "init_fin_final"
  "init_fin"
  "map NormalAction  convert_RA"
  "init_fin_τmove"
by(rule τmultithreaded_wf_init_fin)


primrec init_fin_lift_inv :: "('i  't  'x  'm  bool)  'i  't  status × 'x  'm  bool"
where "init_fin_lift_inv P I t (s, x) = P I t x"

context lifting_inv begin

lemma lifting_inv_init_fin_lift_inv:
  "lifting_inv init_fin_final init_fin (init_fin_lift_inv P)"
proof -
  interpret "if": multithreaded init_fin_final init_fin "map NormalAction  convert_RA"
    by(rule multithreaded_init_fin)
  show ?thesis
    by(unfold_locales)(fastforce elim!: init_fin.cases dest: invariant_red invariant_NewThread invariant_other)+
qed

end

locale if_lifting_inv =
  if_multithreaded +
  lifting_inv +
  constrains final :: "'x  bool" 
  and r :: "('l,'t,'x,'m,'w,'o) semantics" 
  and convert_RA :: "'l released_locks  'o list"
  and P :: "'i  't  'x  'm  bool"

sublocale if_lifting_inv < "if": lifting_inv
  init_fin_final
  init_fin
  "map NormalAction  convert_RA"
  "init_fin_lift_inv P"
by(rule lifting_inv_init_fin_lift_inv)

primrec init_fin_lift :: "('t  'x  'm  bool)  't  status × 'x  'm  bool"
where "init_fin_lift P t (s, x) = P t x"

context lifting_wf begin

lemma lifting_wf_init_fin_lift:
  "lifting_wf init_fin_final init_fin (init_fin_lift P)"
proof -
  interpret "if": multithreaded init_fin_final init_fin "map NormalAction  convert_RA"
    by(rule multithreaded_init_fin)
  show ?thesis
    by(unfold_locales)(fastforce elim!: init_fin.cases dest: dest: preserves_red preserves_other preserves_NewThread)+
qed

end

locale if_lifting_wf =
  if_multithreaded +
  lifting_wf +
  constrains final :: "'x  bool" 
  and r :: "('l,'t,'x,'m,'w,'o) semantics" 
  and convert_RA :: "'l released_locks  'o list"
  and P :: "'t  'x  'm  bool"

sublocale if_lifting_wf < "if": lifting_wf 
  init_fin_final
  init_fin
  "map NormalAction  convert_RA"
  "init_fin_lift P"
by(rule lifting_wf_init_fin_lift)

lemma (in if_lifting_wf) if_lifting_inv:
  "if_lifting_inv final r (λ_::unit. P)"
proof -
  interpret lifting_inv final r convert_RA  "λ_ :: unit. P" by(rule lifting_inv)
  show ?thesis by unfold_locales
qed

locale τlifting_inv = τmultithreaded_wf +
  lifting_inv +
  constrains final :: "'x  bool" 
  and r :: "('l,'t,'x,'m,'w,'o) semantics" 
  and convert_RA :: "'l released_locks  'o list"
  and τmove :: "('l,'t,'x,'m,'w,'o) τmoves"
  and P :: "'i  't  'x  'm  bool"
begin

lemma redT_silent_move_invariant:
  " τmredT s s'; ts_inv P Is (thr s) (shr s)   ts_inv P Is (thr s') (shr s')"
by(auto dest!: redT_invariant mτmove_silentD)

lemma redT_silent_moves_invariant:
  " mthr.silent_moves s s'; ts_inv P Is (thr s) (shr s)   ts_inv P Is (thr s') (shr s')"
by(induct rule: rtranclp_induct)(auto dest: redT_silent_move_invariant)

lemma redT_τrtrancl3p_invariant:
  " mthr.τrtrancl3p s ttas s'; ts_inv P Is (thr s) (shr s) 
   ts_inv P (upd_invs Is P (concat (map (thr_a  snd) ttas))) (thr s') (shr s')"
proof(induct arbitrary: Is rule: mthr.τrtrancl3p.induct)
  case τrtrancl3p_refl thus ?case by simp
next
  case (τrtrancl3p_step s s' tls s'' tl)
  thus ?case by(cases tl)(force dest: redT_invariant)
next
  case (τrtrancl3p_τstep s s' tls s'' tl)
  thus ?case by(cases tl)(force dest: redT_invariant mτmove_silentD)
qed

end

locale τlifting_wf = τmultithreaded +
  lifting_wf +
  constrains final :: "'x  bool" 
  and r :: "('l,'t,'x,'m,'w,'o) semantics" 
  and convert_RA :: "'l released_locks  'o list"
  and τmove :: "('l,'t,'x,'m,'w,'o) τmoves"
  and P :: "'t  'x  'm  bool"
begin

lemma redT_silent_move_preserves:
  " τmredT s s'; ts_ok P (thr s) (shr s)   ts_ok P (thr s') (shr s')"
by(auto dest: redT_preserves)

lemma redT_silent_moves_preserves:
  " mthr.silent_moves s s'; ts_ok P (thr s) (shr s)   ts_ok P (thr s') (shr s')"
by(induct rule: rtranclp.induct)(auto dest: redT_silent_move_preserves)

lemma redT_τrtrancl3p_preserves:
  " mthr.τrtrancl3p s ttas s'; ts_ok P (thr s) (shr s)   ts_ok P (thr s') (shr s')"
by(induct rule: mthr.τrtrancl3p.induct)(auto dest: redT_silent_moves_preserves redT_preserves)

end

definition init_fin_lift_state :: "status  ('l,'t,'x,'m,'w) state  ('l,'t,status × 'x,'m,'w) state"
where "init_fin_lift_state s σ = (locks σ, (λt. map_option (λ(x, ln). ((s, x), ln)) (thr σ t), shr σ), wset σ, interrupts σ)"

definition init_fin_descend_thr :: "('l,'t,'status × 'x) thread_info  ('l,'t,'x) thread_info"
where "init_fin_descend_thr ts = map_option (λ((s, x), ln). (x, ln))  ts"

definition init_fin_descend_state :: "('l,'t,'status × 'x,'m,'w) state  ('l,'t,'x,'m,'w) state"
where "init_fin_descend_state σ = (locks σ, (init_fin_descend_thr (thr σ), shr σ), wset σ, interrupts σ)"

lemma ts_ok_init_fin_lift_init_fin_lift_state [simp]:
  "ts_ok (init_fin_lift P) (thr (init_fin_lift_state s σ)) (shr (init_fin_lift_state s σ))  ts_ok P (thr σ) (shr σ)"
by(auto simp add: init_fin_lift_state_def intro!: ts_okI dest: ts_okD)

lemma ts_inv_init_fin_lift_inv_init_fin_lift_state [simp]:
  "ts_inv (init_fin_lift_inv P) I (thr (init_fin_lift_state s σ)) (shr (init_fin_lift_state s σ))  
   ts_inv P I (thr σ) (shr σ)"
by(auto simp add: init_fin_lift_state_def intro!: ts_invI dest: ts_invD)

lemma init_fin_lift_state_conv_simps:
  shows shr_init_fin_lift_state: "shr (init_fin_lift_state s σ) = shr σ"
  and locks_init_fin_lift_state: "locks (init_fin_lift_state s σ) = locks σ"
  and wset_init_fin_lift_state: "wset (init_fin_lift_state s σ) = wset σ"
  and interrupts_init_fin_lift_stae: "interrupts (init_fin_lift_state s σ) = interrupts σ"
  and thr_init_fin_list_state: 
  "thr (init_fin_lift_state s σ) t = map_option (λ(x, ln). ((s, x), ln)) (thr σ t)"
by(simp_all add: init_fin_lift_state_def)

lemma thr_init_fin_list_state': 
  "thr (init_fin_lift_state s σ) = map_option (λ(x, ln). ((s, x), ln))  thr σ"
by(simp add: fun_eq_iff thr_init_fin_list_state)

lemma init_fin_descend_thr_Some_conv [simp]:
  "ln. ts t = ((status, x), ln)  init_fin_descend_thr ts t = (x, ln)"
by(simp add: init_fin_descend_thr_def)

lemma init_fin_descend_thr_None_conv [simp]:
  "ts t = None  init_fin_descend_thr ts t = None"
by(simp add: init_fin_descend_thr_def)

lemma init_fin_descend_thr_eq_None [simp]:
  "init_fin_descend_thr ts t = None  ts t = None"
by(simp add: init_fin_descend_thr_def)

lemma init_fin_descend_state_simps [simp]:
  "init_fin_descend_state (ls, (ts, m), ws, is) = (ls, (init_fin_descend_thr ts, m), ws, is)"
  "locks (init_fin_descend_state s) = locks s"
  "thr (init_fin_descend_state s) = init_fin_descend_thr (thr s)"
  "shr (init_fin_descend_state s) = shr s"
  "wset (init_fin_descend_state s) = wset s"
  "interrupts (init_fin_descend_state s) = interrupts s"
by(simp_all add: init_fin_descend_state_def)

lemma init_fin_descend_thr_update [simp]:
  "init_fin_descend_thr (ts(t := v)) = (init_fin_descend_thr ts)(t := map_option (λ((status, x), ln). (x, ln)) v)"
by(simp add: init_fin_descend_thr_def fun_eq_iff)

lemma ts_ok_init_fin_descend_state: 
  "ts_ok P (init_fin_descend_thr ts) = ts_ok (init_fin_lift P) ts"
by(rule ext)(auto 4 3 intro!: ts_okI dest: ts_okD simp add: init_fin_descend_thr_def)

lemma free_thread_id_init_fin_descend_thr [simp]: 
  "free_thread_id (init_fin_descend_thr ts) = free_thread_id ts"
by(simp add: free_thread_id.simps fun_eq_iff)

lemma redT_updT'_init_fin_descend_thr_eq_None [simp]:
  "redT_updT' (init_fin_descend_thr ts) nt t = None  redT_updT' ts nt t = None"
by(cases nt) simp_all

lemma thread_ok_init_fin_descend_thr [simp]: 
  "thread_ok (init_fin_descend_thr ts) nta = thread_ok ts nta"
by(cases nta) simp_all

lemma threads_ok_init_fin_descend_thr [simp]:
  "thread_oks (init_fin_descend_thr ts) ntas = thread_oks ts ntas"
by(induct ntas arbitrary: ts)(auto elim!: thread_oks_ts_change[THEN iffD1, rotated 1])

lemma init_fin_descend_thr_redT_updT [simp]:
  "init_fin_descend_thr (redT_updT ts (convert_new_thread_action (Pair status) nt)) =
   redT_updT (init_fin_descend_thr ts) nt"
by(cases nt) simp_all

lemma init_fin_descend_thr_redT_updTs [simp]:
  "init_fin_descend_thr (redT_updTs ts (map (convert_new_thread_action (Pair status)) nts)) =
   redT_updTs (init_fin_descend_thr ts) nts"
by(induct nts arbitrary: ts) simp_all

context final_thread begin

lemma cond_action_ok_init_fin_descend_stateI [simp]:
  "final_thread.cond_action_ok init_fin_final s t ct  cond_action_ok (init_fin_descend_state s) t ct"
by(cases ct)(auto simp add: final_thread.cond_action_ok.simps init_fin_descend_thr_def)

lemma cond_action_oks_init_fin_descend_stateI [simp]:
  "final_thread.cond_action_oks init_fin_final s t cts  cond_action_oks (init_fin_descend_state s) t cts"
by(induct cts)(simp_all add: final_thread.cond_action_oks.simps cond_action_ok_init_fin_descend_stateI)

end


definition lift_start_obs :: "'t  'o list  ('t × 'o action) list"
where "lift_start_obs t obs = (t, InitialThreadAction) # map (λob. (t, NormalAction ob)) obs"

lemma length_lift_start_obs [simp]: "length (lift_start_obs t obs) = Suc (length obs)"
by(simp add: lift_start_obs_def)

lemma set_lift_start_obs [simp]:
  "set (lift_start_obs t obs) =
   insert (t, InitialThreadAction) ((Pair t  NormalAction) ` set obs)"
by(auto simp add: lift_start_obs_def o_def)

lemma distinct_lift_start_obs [simp]: "distinct (lift_start_obs t obs) = distinct obs"
by(auto simp add: lift_start_obs_def distinct_map intro: inj_onI)

end

Theory FWBisimLift

theory FWBisimLift imports
  FWInitFinLift
  FWBisimulation
begin

context FWbisimulation_base begin

inductive init_fin_bisim :: "'t  ((status × 'x1) × 'm1, (status × 'x2) × 'm2) bisim"
  ("_  _ ≈i _"[50,50,50] 60)
for t :: 't
where
  PreStart: "t  (x1, m1)  (x2, m2)  t  ((PreStart, x1), m1) ≈i ((PreStart, x2), m2)"
| Running: "t  (x1, m1)  (x2, m2)  t  ((Running, x1), m1) ≈i ((Running, x2), m2)"
| Finished: 
    " t  (x1, m1)  (x2, m2); final1 x1; final2 x2 
     t  ((Finished, x1), m1) ≈i ((Finished, x2), m2)"

definition init_fin_bisim_wait :: "(status × 'x1, status × 'x2) bisim" ("_ ≈iw _" [50,50] 60)
where 
  "init_fin_bisim_wait = (λ(status1, x1) (status2, x2). status1 = Running  status2 = Running  x1 ≈w x2)"

inductive_simps init_fin_bisim_simps [simp]:
  "t  ((PreStart, x1), m1) ≈i ((s2, x2), m2)"
  "t  ((Running, x1), m1) ≈i ((s2, x2), m2)"
  "t  ((Finished, x1), m1) ≈i ((s2, x2), m2)"
  "t  ((s1, x1), m1) ≈i ((PreStart, x2), m2)"
  "t  ((s1, x1), m1) ≈i ((Running, x2), m2)"
  "t  ((s1, x1), m1) ≈i ((Finished, x2), m2)"

lemma init_fin_bisim_iff:
  "t  ((s1, x1), m1) ≈i ((s2, x2), m2)  
   s1 = s2  t  (x1, m1)  (x2, m2)  (s2 = Finished  final1 x1  final2 x2)"
by(cases s1) auto

lemma nta_bisim_init_fin_bisim [simp]:
  "nta_bisim init_fin_bisim (convert_new_thread_action (Pair PreStart) nt1)
      (convert_new_thread_action (Pair PreStart) nt2) =
   nta_bisim bisim nt1 nt2"
by(cases nt1) simp_all

lemma ta_bisim_init_fin_bisim_convert [simp]:
  "ta_bisim init_fin_bisim (convert_TA_initial (convert_obs_initial ta1)) (convert_TA_initial (convert_obs_initial ta2))  ta1 ∼m ta2"
by(auto simp add: ta_bisim_def list_all2_map1 list_all2_map2)

lemma ta_bisim_init_fin_bisim_InitialThreadAction [simp]:
  "ta_bisim init_fin_bisim InitialThreadAction InitialThreadAction"
by(simp add: ta_bisim_def)

lemma ta_bisim_init_fin_bisim_ThreadFinishAction [simp]:
  "ta_bisim init_fin_bisim ThreadFinishAction ThreadFinishAction"
by(simp add: ta_bisim_def)

lemma init_fin_bisim_wait_simps [simp]:
  "(status1, x1) ≈iw (status2, x2)  status1 = Running  status2 = Running  x1 ≈w x2"
by(simp add: init_fin_bisim_wait_def)

lemma init_fin_lift_state_mbisimI:
  "s ≈m s' 
  FWbisimulation_base.mbisim init_fin_bisim init_fin_bisim_wait (init_fin_lift_state Running s) (init_fin_lift_state Running s')"
apply(rule FWbisimulation_base.mbisimI)
      apply(simp add: thr_init_fin_list_state' o_def dom_map_option mbisim_finite1)
     apply(simp add: locks_init_fin_lift_state mbisim_def)
    apply(simp add: wset_init_fin_lift_state mbisim_def)
   apply(simp add: interrupts_init_fin_lift_stae mbisim_def)
  apply(clarsimp simp add: wset_init_fin_lift_state mbisim_def thr_init_fin_list_state' o_def wset_thread_ok_conv_dom dom_map_option del: subsetI)
 apply(drule_tac t=t in mbisim_thrNone_eq)
 apply(simp add: thr_init_fin_list_state)
apply(clarsimp simp add: thr_init_fin_list_state shr_init_fin_lift_state wset_init_fin_lift_state init_fin_bisim_iff)
apply(frule (1) mbisim_thrD1)
apply(simp add: mbisim_def)
done

end

context FWdelay_bisimulation_base begin

lemma init_fin_delay_bisimulation_final_base:
  "delay_bisimulation_final_base (r1.init_fin t) (r2.init_fin t) (init_fin_bisim t) 
     r1.init_fin_τmove r2.init_fin_τmove (λ(x1, m). r1.init_fin_final x1) (λ(x2, m). r2.init_fin_final x2)"
by(unfold_locales)(auto 4 3)

end

lemma init_fin_bisim_flip [flip_simps]:
  "FWbisimulation_base.init_fin_bisim final2 final1 (λt. flip (bisim t)) =
   (λt. flip (FWbisimulation_base.init_fin_bisim final1 final2 bisim t))"
by(auto simp only: FWbisimulation_base.init_fin_bisim_iff flip_simps fun_eq_iff split_paired_Ex)

lemma init_fin_bisim_wait_flip [flip_simps]:
  "FWbisimulation_base.init_fin_bisim_wait (flip bisim_wait) =
   flip (FWbisimulation_base.init_fin_bisim_wait bisim_wait)"
by(auto simp add: fun_eq_iff FWbisimulation_base.init_fin_bisim_wait_simps flip_simps)

context FWdelay_bisimulation_lift_aux begin

lemma init_fin_FWdelay_bisimulation_lift_aux:
  "FWdelay_bisimulation_lift_aux r1.init_fin_final r1.init_fin r2.init_fin_final r2.init_fin r1.init_fin_τmove r2.init_fin_τmove"
by(intro FWdelay_bisimulation_lift_aux.intro r1.τmultithreaded_wf_init_fin r2.τmultithreaded_wf_init_fin)

lemma init_fin_FWdelay_bisimulation_final_base:
  "FWdelay_bisimulation_final_base 
     r1.init_fin_final r1.init_fin r2.init_fin_final r2.init_fin 
     init_fin_bisim r1.init_fin_τmove r2.init_fin_τmove"
by(intro FWdelay_bisimulation_final_base.intro init_fin_FWdelay_bisimulation_lift_aux FWdelay_bisimulation_final_base_axioms.intro init_fin_delay_bisimulation_final_base)

end

context FWdelay_bisimulation_obs begin

lemma init_fin_simulation1:
  assumes bisim: "t  s1 ≈i s2"
    and red1: "r1.init_fin t s1 tl1 s1'"
    and τ1: "¬ r1.init_fin_τmove s1 tl1 s1'"
  shows "s2' s2'' tl2. (τtrsys.silent_move (r2.init_fin t) r2.init_fin_τmove)** s2 s2' 
             r2.init_fin t s2' tl2 s2''  ¬ r2.init_fin_τmove s2' tl2 s2'' 
             t  s1' ≈i s2''  ta_bisim init_fin_bisim tl1 tl2"
proof -
  from bisim obtain status x1 m1 x2 m2 
    where s1: "s1 = ((status, x1), m1)"
    and s2: "s2 = ((status, x2), m2)"
    and bisim: "t  (x1, m1)  (x2, m2)"
    and finished: "status = Finished  final1 x1  final2 x2"
    by(cases s1)(cases s2, fastforce simp add: init_fin_bisim_iff)
  from red1 show ?thesis unfolding s1
  proof(cases)
    case (NormalAction ta1 x1' m1')
    with τ1 s1 have "¬ τmove1 (x1, m1) ta1 (x1', m1')" by(simp)
    from simulation1[OF bisim t  (x1, m1) -1-ta1 (x1', m1') this]
    obtain x2' m2' x2'' m2'' ta2
      where red2: "r2.silent_moves t (x2, m2) (x2', m2')"
      and red2': "t  (x2', m2') -2-ta2 (x2'', m2'')"
      and τ2: "¬ τmove2 (x2', m2') ta2 (x2'', m2'')"
      and bisim': "t  (x1', m1')  (x2'', m2'')"
      and tasim: "ta1 ∼m ta2" by auto
    let ?s2' = "((Running, x2'), m2')"
    let ?s2'' = "((Running, x2''), m2'')"
    let ?ta2 = "(convert_TA_initial (convert_obs_initial ta2))"
    from red2 have "τtrsys.silent_moves (r2.init_fin t) r2.init_fin_τmove s2 ?s2'"
      unfolding s2 status = Running› by(rule r2.init_fin_silent_moves_RunningI)
    moreover from red2' have "r2.init_fin t ?s2' ?ta2 ?s2''" by(rule r2.init_fin.NormalAction)
    moreover from τ2 have "¬ r2.init_fin_τmove ?s2' ?ta2 ?s2''" by simp
    moreover from bisim' have "t  s1' ≈i ?s2''"using s1' = ((Running, x1'), m1') by simp
    moreover from tasim tl1 = convert_TA_initial (convert_obs_initial ta1)
    have "ta_bisim init_fin_bisim tl1 ?ta2" by simp
    ultimately show ?thesis by blast
  next
    case InitialThreadAction
    with s1 s2 bisim show ?thesis by(auto simp del: split_paired_Ex)
  next
    case ThreadFinishAction
    from final1_simulation[OF bisim] final1 x1
    obtain x2' m2' where red2: "r2.silent_moves t (x2, m2) (x2', m2')"
      and bisim': "t  (x1, m1)  (x2', m2')"
      and fin2: "final2 x2'" by auto
    let ?s2' = "((Running, x2'), m2')"
    let ?s2'' = "((Finished, x2'), m2')"
    from red2 have "τtrsys.silent_moves (r2.init_fin t) r2.init_fin_τmove s2 ?s2'"
      unfolding s2 status = Running› by(rule r2.init_fin_silent_moves_RunningI)
    moreover from fin2 have "r2.init_fin t ?s2' ThreadFinishAction ?s2''" ..
    moreover have "¬ r2.init_fin_τmove ?s2' ThreadFinishAction ?s2''" by simp
    moreover have "t  s1' ≈i ?s2''"
      using s1' = ((Finished, x1), m1) fin2 final1 x1 bisim' by simp
    ultimately show ?thesis unfolding tl1 = ThreadFinishAction
      by(blast intro: ta_bisim_init_fin_bisim_ThreadFinishAction)
  qed
qed

lemma init_fin_simulation2:
  " t  s1 ≈i s2; r2.init_fin t s2 tl2 s2'; ¬ r2.init_fin_τmove s2 tl2 s2' 
   s1' s1'' tl1. (τtrsys.silent_move (r1.init_fin t) r1.init_fin_τmove)** s1 s1' 
             r1.init_fin t s1' tl1 s1''  ¬ r1.init_fin_τmove s1' tl1 s1'' 
             t  s1'' ≈i s2'  ta_bisim init_fin_bisim tl1 tl2"
using FWdelay_bisimulation_obs.init_fin_simulation1[OF FWdelay_bisimulation_obs_flip]
unfolding flip_simps .

lemma init_fin_simulation_Wakeup1:
  assumes bisim: "t  (sx1, m1) ≈i (sx2, m2)"
  and wait: "sx1 ≈iw sx2"
  and red1: "r1.init_fin t (sx1, m1) ta1 (sx1', m1')"
  and wakeup: "Notified  set ta1w  WokenUp  set ta1w"
  shows "ta2 sx2' m2'. r2.init_fin t (sx2, m2) ta2 (sx2', m2')  t  (sx1', m1') ≈i (sx2', m2')  
                        ta_bisim init_fin_bisim ta1 ta2"
proof -
  from bisim wait obtain status x1 x2 
    where sx1: "sx1 = (status, x1)"
    and sx2: "sx2 = (status, x2)"
    and Bisim: "t  (x1, m1)  (x2, m2)"
    and Wait: "x1 ≈w x2" by cases auto
  from red1 wakeup sx1 obtain x1' ta1' 
    where sx1': "sx1' = (Running, x1')"
    and status: "status = Running"
    and Red1: "t  (x1, m1) -1-ta1' (x1', m1')"
    and ta1: "ta1 = convert_TA_initial (convert_obs_initial ta1')"
    and Wakeup: "Notified  set ta1'w  WokenUp  set ta1'w"
    by cases auto
  from simulation_Wakeup1[OF Bisim Wait Red1 Wakeup] obtain ta2' x2' m2'
    where red2: "t  (x2, m2) -2-ta2' (x2', m2')"
    and bisim': "t  (x1', m1')  (x2', m2')" 
    and tasim: "ta1' ∼m ta2'" by blast
  let ?sx2' = "(Running, x2')"
  let ?ta2 = "convert_TA_initial (convert_obs_initial ta2')"
  from red2 have "r2.init_fin t (sx2, m2) ?ta2 (?sx2', m2')" unfolding sx2 status ..
  moreover from bisim' sx1' have "t  (sx1', m1') ≈i (?sx2', m2')" by simp
  moreover from tasim ta1 have "ta_bisim init_fin_bisim ta1 ?ta2" by simp
  ultimately show ?thesis by blast
qed

lemma init_fin_simulation_Wakeup2:
  " t  (sx1, m1) ≈i (sx2, m2); sx1 ≈iw sx2; r2.init_fin t (sx2, m2) ta2 (sx2', m2');
    Notified  set ta2w  WokenUp  set ta2w 
   ta1 sx1' m1'. r1.init_fin t (sx1, m1) ta1 (sx1', m1')  t  (sx1', m1') ≈i (sx2', m2')  
                     ta_bisim init_fin_bisim ta1 ta2"
using FWdelay_bisimulation_obs.init_fin_simulation_Wakeup1[OF FWdelay_bisimulation_obs_flip]
unfolding flip_simps .

lemma init_fin_delay_bisimulation_obs:
  "delay_bisimulation_obs (r1.init_fin t) (r2.init_fin t) (init_fin_bisim t) (ta_bisim init_fin_bisim)
         r1.init_fin_τmove r2.init_fin_τmove"
by(unfold_locales)(erule (2) init_fin_simulation1 init_fin_simulation2)+

lemma init_fin_FWdelay_bisimulation_obs:
  "FWdelay_bisimulation_obs r1.init_fin_final r1.init_fin r2.init_fin_final r2.init_fin init_fin_bisim init_fin_bisim_wait r1.init_fin_τmove r2.init_fin_τmove"
proof(intro FWdelay_bisimulation_obs.intro init_fin_FWdelay_bisimulation_final_base FWdelay_bisimulation_obs_axioms.intro init_fin_delay_bisimulation_obs)
  fix t' sx m1 sxx m2 t sx1 sx2 sx1' ta1 sx1'' m1' sx2' ta2 sx2'' m2'
  assume bisim: "t'  (sx, m1) ≈i (sxx, m2)" 
    and bisim1: "t  (sx1, m1) ≈i (sx2, m2)"
    and red1: "τtrsys.silent_moves (r1.init_fin t) r1.init_fin_τmove (sx1, m1) (sx1', m1)"
    and red1': "r1.init_fin t (sx1', m1) ta1 (sx1'', m1')"
    and τ1: "¬ r1.init_fin_τmove (sx1', m1) ta1 (sx1'', m1')"
    and red2: "τtrsys.silent_moves (r2.init_fin t) r2.init_fin_τmove (sx2, m2) (sx2', m2)"
    and red2':"r2.init_fin t (sx2', m2) ta2 (sx2'', m2')"
    and τ2: "¬ r2.init_fin_τmove (sx2', m2) ta2 (sx2'', m2')"
    and bisim1': "t  (sx1'', m1') ≈i (sx2'', m2')"
    and tasim: "ta_bisim init_fin_bisim ta1 ta2"
  from bisim obtain status x xx 
    where sx:"sx = (status, x)"
    and sxx: "sxx = (status, xx)"
    and Bisim: "t'  (x, m1)  (xx, m2)"
    and Finish: "status = Finished  final1 x  final2 xx"
    by(cases sx)(cases sxx, auto simp add: init_fin_bisim_iff)
  from bisim1 obtain status1 x1 x2
    where sx1: "sx1 = (status1, x1)"
    and sx2: "sx2 = (status1, x2)"
    and Bisim1: "t  (x1, m1)  (x2, m2)"
    by(cases sx1)(cases sx2, auto simp add: init_fin_bisim_iff)
  from bisim1' obtain status1' x1'' x2''
    where sx1'': "sx1'' = (status1', x1'')"
    and sx2'': "sx2'' = (status1', x2'')"
    and Bisim1': "t  (x1'', m1')  (x2'', m2')"
     by(cases sx1'')(cases sx2'', auto simp add: init_fin_bisim_iff)
  from red1 sx1 obtain x1' where sx1': "sx1' = (status1, x1')"
    and Red1: "r1.silent_moves t (x1, m1) (x1', m1)"
    by(cases sx1')(auto dest: r1.init_fin_silent_movesD)
  from red2 sx2 obtain x2' where sx2': "sx2' = (status1, x2')"
    and Red2: "r2.silent_moves t (x2, m2) (x2', m2)"
    by(cases sx2')(auto dest: r2.init_fin_silent_movesD)
  show "t'  (sx, m1') ≈i (sxx, m2')"
  proof(cases "status1 = Running  status1' = Running")
    case True
    with red1' sx1' sx1'' obtain ta1'
      where Red1': "t  (x1', m1) -1-ta1' (x1'', m1')"
      and ta1: "ta1 = convert_TA_initial (convert_obs_initial ta1')"
      by cases auto
    from red2' sx2' sx2'' True obtain ta2'
      where Red2': "t  (x2', m2) -2-ta2' (x2'', m2')"
      and ta2: "ta2 = convert_TA_initial (convert_obs_initial ta2')"
      by cases auto
    from τ1 sx1' sx1'' ta1 True have τ1':"¬ τmove1 (x1', m1) ta1' (x1'', m1')" by simp
    from τ2 sx2' sx2'' ta2 True have τ2':"¬ τmove2 (x2', m2) ta2' (x2'', m2')" by simp
    from tasim ta1 ta2 have "ta1' ∼m ta2'" by simp
    with Bisim Bisim1 Red1 Red1' τ1' Red2 Red2' τ2' Bisim1'
    have "t'  (x, m1')  (xx, m2')" by(rule bisim_inv_red_other)
    with True Finish show ?thesis unfolding sx sxx by(simp add: init_fin_bisim_iff)
  next
    case False
    with red1' sx1' sx1'' have "m1' = m1" by cases auto
    moreover from red2' sx2' sx2'' False have "m2' = m2" by cases auto
    ultimately show ?thesis using bisim by simp
  qed
next
  fix t sx1 m1 sx2 m2 sx1' ta1 sx1'' m1' sx2' ta2 sx2'' m2' w
  assume bisim: "t  (sx1, m1) ≈i (sx2, m2)"
    and red1: "τtrsys.silent_moves (r1.init_fin t) r1.init_fin_τmove (sx1, m1) (sx1', m1)"
    and red1': "r1.init_fin t (sx1', m1) ta1 (sx1'', m1')"
    and τ1: "¬ r1.init_fin_τmove (sx1', m1) ta1 (sx1'', m1')"
    and red2: "τtrsys.silent_moves (r2.init_fin t) r2.init_fin_τmove (sx2, m2) (sx2', m2)"
    and red2': "r2.init_fin t (sx2', m2) ta2 (sx2'', m2')"
    and τ2: "¬ r2.init_fin_τmove (sx2', m2) ta2 (sx2'', m2')"
    and bisim': "t  (sx1'', m1') ≈i (sx2'', m2')"
    and tasim: "ta_bisim init_fin_bisim ta1 ta2"
    and suspend1: "Suspend w  set ta1w"
    and suspend2: "Suspend w  set ta2w"
  from bisim obtain status x1 x2
    where sx1: "sx1 = (status, x1)"
    and sx2: "sx2 = (status, x2)"
    and Bisim: "t  (x1, m1)  (x2, m2)"
    by(cases sx1)(cases sx2, auto simp add: init_fin_bisim_iff)
  from bisim' obtain status' x1'' x2''
    where sx1'': "sx1'' = (status', x1'')"
    and sx2'': "sx2'' = (status', x2'')"
    and Bisim': "t  (x1'', m1')  (x2'', m2')"
     by(cases sx1'')(cases sx2'', auto simp add: init_fin_bisim_iff)
  from red1 sx1 obtain x1' where sx1': "sx1' = (status, x1')"
    and Red1: "r1.silent_moves t (x1, m1) (x1', m1)"
    by(cases sx1')(auto dest: r1.init_fin_silent_movesD)
  from red2 sx2 obtain x2' where sx2': "sx2' = (status, x2')"
    and Red2: "r2.silent_moves t (x2, m2) (x2', m2)"
    by(cases sx2')(auto dest: r2.init_fin_silent_movesD)
  from red1' sx1' sx1'' suspend1 obtain ta1'
    where Red1': "t  (x1', m1) -1-ta1' (x1'', m1')"
    and ta1: "ta1 = convert_TA_initial (convert_obs_initial ta1')"
    and Suspend1: "Suspend w  set ta1'w"
    and status: "status = Running" "status' = Running" by cases auto
  from red2' sx2' sx2'' suspend2 obtain ta2'
    where Red2': "t  (x2', m2) -2-ta2' (x2'', m2')"
    and ta2: "ta2 = convert_TA_initial (convert_obs_initial ta2')"
    and Suspend2: "Suspend w  set ta2'w" by cases auto
  from τ1 sx1' sx1'' ta1 status have τ1':"¬ τmove1 (x1', m1) ta1' (x1'', m1')" by simp
  from τ2 sx2' sx2'' ta2 status have τ2':"¬ τmove2 (x2', m2) ta2' (x2'', m2')" by simp
  from tasim ta1 ta2 have "ta1' ∼m ta2'" by simp
  with Bisim Red1 Red1' τ1' Red2 Red2' τ2' Bisim' have "x1'' ≈w x2''" 
    using Suspend1 Suspend2 by(rule bisim_waitI)
  thus "sx1'' ≈iw sx2''" using sx1'' sx2'' status by simp
next
  fix t sx1 m1 sx2 m2 ta1 sx1' m1'
  assume "t  (sx1, m1) ≈i (sx2, m2)" and "sx1 ≈iw sx2"
    and "r1.init_fin t (sx1, m1) ta1 (sx1', m1')"
    and "Notified  set ta1w  WokenUp  set ta1w"
  thus "ta2 sx2' m2'. r2.init_fin t (sx2, m2) ta2 (sx2', m2')  t  (sx1', m1') ≈i (sx2', m2')  
                       ta_bisim init_fin_bisim ta1 ta2"
    by(rule init_fin_simulation_Wakeup1)
next
  fix t sx1 m1 sx2 m2 ta2 sx2' m2'
  assume "t  (sx1, m1) ≈i (sx2, m2)" and "sx1 ≈iw sx2"
    and "r2.init_fin t (sx2, m2) ta2 (sx2', m2')"
    and "Notified  set ta2w  WokenUp  set ta2w"
  thus "ta1 sx1' m1'. r1.init_fin t (sx1, m1) ta1 (sx1', m1')  t  (sx1', m1') ≈i (sx2', m2')  
                       ta_bisim init_fin_bisim ta1 ta2"
    by(rule init_fin_simulation_Wakeup2)
next
  show "(sx1. r1.init_fin_final sx1) = (sx2. r2.init_fin_final sx2)"
    using ex_final1_conv_ex_final2 by(auto)
qed

end

context FWdelay_bisimulation_diverge begin

lemma init_fin_simulation_silent1:
  " t  sxm1 ≈i sxm2; τtrsys.silent_move (r1.init_fin t) r1.init_fin_τmove sxm1 sxm1' 
   sxm2'. τtrsys.silent_moves (r2.init_fin t) r2.init_fin_τmove sxm2 sxm2'  t  sxm1' ≈i sxm2'"
by(cases sxm1')(auto 4 4 elim!: init_fin_bisim.cases dest!: r1.init_fin_silent_moveD dest: simulation_silent1 intro!: r2.init_fin_silent_moves_RunningI)

lemma init_fin_simulation_silent2:
  " t  sxm1 ≈i sxm2; τtrsys.silent_move (r2.init_fin t) r2.init_fin_τmove sxm2 sxm2' 
   sxm1'. τtrsys.silent_moves (r1.init_fin t) r1.init_fin_τmove sxm1 sxm1'  t  sxm1' ≈i sxm2'"
using FWdelay_bisimulation_diverge.init_fin_simulation_silent1[OF FWdelay_bisimulation_diverge_flip]
unfolding flip_simps .

lemma init_fin_τdiverge_bisim_inv:
  "t  sxm1 ≈i sxm2 
   τtrsys.τdiverge (r1.init_fin t) r1.init_fin_τmove sxm1 =
      τtrsys.τdiverge (r2.init_fin t) r2.init_fin_τmove sxm2"
by(cases sxm1)(cases sxm2, auto simp add: r1.init_fin_τdiverge_conv r2.init_fin_τdiverge_conv init_fin_bisim_iff τdiverge_bisim_inv)

lemma init_fin_delay_bisimulation_diverge:
  "delay_bisimulation_diverge (r1.init_fin t) (r2.init_fin t) (init_fin_bisim t) (ta_bisim init_fin_bisim)
         r1.init_fin_τmove r2.init_fin_τmove"
by(blast intro: delay_bisimulation_diverge.intro init_fin_delay_bisimulation_obs delay_bisimulation_diverge_axioms.intro init_fin_simulation_silent1 init_fin_simulation_silent2 init_fin_τdiverge_bisim_inv del: iffI)+

lemma init_fin_FWdelay_bisimulation_diverge:
  "FWdelay_bisimulation_diverge r1.init_fin_final r1.init_fin r2.init_fin_final r2.init_fin init_fin_bisim init_fin_bisim_wait r1.init_fin_τmove r2.init_fin_τmove"
by(intro FWdelay_bisimulation_diverge.intro init_fin_FWdelay_bisimulation_obs FWdelay_bisimulation_diverge_axioms.intro init_fin_delay_bisimulation_diverge)

end

context FWbisimulation begin

lemma init_fin_simulation1:
  assumes "t  s1 ≈i s2" and "r1.init_fin t s1 tl1 s1'"
  shows "s2' tl2. r2.init_fin t s2 tl2 s2'  t  s1' ≈i s2'  ta_bisim init_fin_bisim tl1 tl2"
using init_fin_simulation1[OF assms] by(auto simp add: τmoves_False init_fin_τmoves_False)

lemma init_fin_simulation2:
  " t  s1 ≈i s2; r2.init_fin t s2 tl2 s2' 
   s1' tl1. r1.init_fin t s1 tl1 s1'  t  s1' ≈i s2'  ta_bisim init_fin_bisim tl1 tl2"
using FWbisimulation.init_fin_simulation1[OF FWbisimulation_flip]
unfolding flip_simps .

lemma init_fin_bisimulation: 
  "bisimulation (r1.init_fin t) (r2.init_fin t)  (init_fin_bisim t) (ta_bisim init_fin_bisim)"
by(unfold_locales)(erule (1) init_fin_simulation1 init_fin_simulation2)+

lemma init_fin_FWbisimulation:
  "FWbisimulation r1.init_fin_final r1.init_fin r2.init_fin_final r2.init_fin init_fin_bisim"
proof(intro FWbisimulation.intro r1.multithreaded_init_fin r2.multithreaded_init_fin FWbisimulation_axioms.intro init_fin_bisimulation)
  fix t sx1 m1 sx2 m2
  assume "t  (sx1, m1) ≈i (sx2, m2)"
  thus "r1.init_fin_final sx1 = r2.init_fin_final sx2"
    by cases simp_all
next
  fix t' sx m1 sxx m2 t sx1 sx2 ta1 sx1' m1' ta2 sx2' m2'
  assume "t'  (sx, m1) ≈i (sxx, m2)" "t  (sx1, m1) ≈i (sx2, m2)"
    and "r1.init_fin t (sx1, m1) ta1 (sx1', m1')"
    and "r2.init_fin t (sx2, m2) ta2 (sx2', m2')"
    and "t  (sx1', m1') ≈i (sx2', m2')"
    and "ta_bisim init_fin_bisim ta1 ta2"
  from FWdelay_bisimulation_obs.bisim_inv_red_other
  [OF init_fin_FWdelay_bisimulation_obs, OF this(1-2) _ this(3) _ _ this(4) _ this(5-6)]
  show "t'  (sx, m1') ≈i (sxx, m2')" by(simp add: init_fin_τmoves_False)
next
  show "(sx1. r1.init_fin_final sx1) = (sx2. r2.init_fin_final sx2)"
    using ex_final1_conv_ex_final2 by(auto)
qed

end

end

Theory Semilat

(*  Title:      HOL/MicroJava/BV/Semilat.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM

Semilattices.
*)

chapter ‹Data Flow Analysis Framework \label{cha:bv}›

section ‹Semilattices›

theory Semilat
imports Main "HOL-Library.While_Combinator"
begin

type_synonym 'a ord    = "'a  'a  bool"
type_synonym 'a binop  = "'a  'a  'a"
type_synonym 'a sl     = "'a set × 'a ord × 'a binop"

definition lesub :: "'a  'a ord  'a  bool"
  where "lesub x r y  r x y"

definition lesssub :: "'a  'a ord  'a  bool"
  where "lesssub x r y  lesub x r y  x  y"

definition plussub :: "'a  ('a  'b  'c)  'b  'c"
  where "plussub x f y = f x y"

notation (ASCII)
  "lesub"  ("(_ /<='__ _)" [50, 1000, 51] 50) and
  "lesssub"  ("(_ /<'__ _)" [50, 1000, 51] 50) and
  "plussub"  ("(_ /+'__ _)" [65, 1000, 66] 65)

notation
  "lesub"  ("(_ /⊑⇘_ _)" [50, 0, 51] 50) and
  "lesssub"  ("(_ /⊏⇘_ _)" [50, 0, 51] 50) and
  "plussub"  ("(_ /⊔⇘_ _)" [65, 0, 66] 65)

(* allow \<sub> instead of \<bsub>..\<esub> *)
abbreviation (input)
  lesub1 :: "'a  'a ord  'a  bool" ("(_ /⊑⇩_ _)" [50, 1000, 51] 50)
  where "x ⊑⇩r y == xr y"

abbreviation (input)
  lesssub1 :: "'a  'a ord  'a  bool" ("(_ /⊏⇩_ _)" [50, 1000, 51] 50)
  where "x ⊏⇩r y == xr y"

abbreviation (input)
  plussub1 :: "'a  ('a  'b  'c)  'b  'c" ("(_ /⊔⇩_ _)" [65, 1000, 66] 65)
  where "x ⊔⇩f y == xf y"

definition ord :: "('a × 'a) set  'a ord"
where
  "ord r = (λx y. (x,y)  r)"

definition order :: "'a ord  bool"
where
  "order r  (x. x ⊑⇩r x)  (x y. x ⊑⇩r y  y ⊑⇩r x  x=y)  (x y z. x ⊑⇩r y  y ⊑⇩r z  x ⊑⇩r z)"

definition top :: "'a ord  'a  bool"
where
  "top r T  (x. x ⊑⇩r T)"
  
definition acc :: "'a set  'a ord  bool"
where
  "acc A r  wf {(y,x). x  A  y  A  x ⊏⇩r y}"

definition closed :: "'a set  'a binop  bool"
where
  "closed A f  (xA. yA. x ⊔⇩f y  A)"

definition semilat :: "'a sl  bool"
where
  "semilat = (λ(A,r,f). order r  closed A f  
                       (xA. yA. x ⊑⇩r x ⊔⇩f y) 
                       (xA. yA. y ⊑⇩r x ⊔⇩f y) 
                       (xA. yA. zA. x ⊑⇩r z  y ⊑⇩r z  x ⊔⇩f y ⊑⇩r z))"

definition is_ub :: "('a × 'a) set  'a  'a  'a  bool"
where
  "is_ub r x y u  (x,u)r  (y,u)r"

definition is_lub :: "('a × 'a) set  'a  'a  'a  bool"
where
  "is_lub r x y u  is_ub r x y u  (z. is_ub r x y z  (u,z)r)"

definition some_lub :: "('a × 'a) set  'a  'a  'a"
where
  "some_lub r x y = (SOME z. is_lub r x y z)"

locale Semilat =
  fixes A :: "'a set"
  fixes r :: "'a ord"
  fixes f :: "'a binop"
  assumes semilat: "semilat (A, r, f)"

lemma order_refl [simp, intro]: "order r  x ⊑⇩r x"
  (*<*) by (unfold order_def) (simp (no_asm_simp)) (*>*)

lemma order_antisym: " order r; x ⊑⇩r y; y ⊑⇩r x   x = y"
  (*<*) by (unfold order_def) (simp (no_asm_simp)) (*>*)

lemma order_trans: " order r; x ⊑⇩r y; y ⊑⇩r z   x ⊑⇩r z"
  (*<*) by (unfold order_def) blast (*>*)

lemma order_less_irrefl [intro, simp]: "order r  ¬ x ⊏⇩r x"
  (*<*) by (unfold order_def lesssub_def) blast (*>*)

lemma order_less_trans: " order r; x ⊏⇩r y; y ⊏⇩r z   x ⊏⇩r z"
  (*<*) by (unfold order_def lesssub_def) blast (*>*)

lemma topD [simp, intro]: "top r T  x ⊑⇩r T"
  (*<*) by (simp add: top_def) (*>*)

lemma top_le_conv [simp]: " order r; top r T   (T ⊑⇩r x) = (x = T)"
  (*<*) by (blast intro: order_antisym) (*>*)

lemma semilat_Def:
"semilat(A,r,f)  order r  closed A f  
                 (xA. yA. x ⊑⇩r x ⊔⇩f y)  
                 (xA. yA. y ⊑⇩r x ⊔⇩f y)  
                 (xA. yA. zA. x ⊑⇩r z  y ⊑⇩r z  x ⊔⇩f y ⊑⇩r z)"
  (*<*) by (unfold semilat_def) clarsimp (*>*)

lemma (in Semilat) orderI [simp, intro]: "order r"
  (*<*) using semilat by (simp add: semilat_Def) (*>*)

lemma (in Semilat) closedI [simp, intro]: "closed A f"
  (*<*) using semilat by (simp add: semilat_Def) (*>*)

lemma closedD: " closed A f; xA; yA   x ⊔⇩f y  A"
  (*<*) by (unfold closed_def) blast (*>*)

lemma closed_UNIV [simp]: "closed UNIV f"
  (*<*) by (simp add: closed_def) (*>*)

lemma (in Semilat) closed_f [simp, intro]: "x  A; y  A   x ⊔⇩f y  A"
  (*<*) by (simp add: closedD [OF closedI]) (*>*)

lemma (in Semilat) refl_r [intro, simp]: "x ⊑⇩r x" by simp

lemma (in Semilat) antisym_r [intro?]: " x ⊑⇩r y; y ⊑⇩r x   x = y"
  (*<*) by (rule order_antisym) auto (*>*)
  
lemma (in Semilat) trans_r [trans, intro?]: "x ⊑⇩r y; y ⊑⇩r z  x ⊑⇩r z"
  (*<*) by (auto intro: order_trans) (*>*)
  
lemma (in Semilat) ub1 [simp, intro?]: " x  A; y  A   x ⊑⇩r x ⊔⇩f y"
  (*<*) by (insert semilat) (unfold semilat_Def, simp) (*>*)

lemma (in Semilat) ub2 [simp, intro?]: " x  A; y  A   y ⊑⇩r x ⊔⇩f y"
  (*<*) by (insert semilat) (unfold semilat_Def, simp) (*>*)

lemma (in Semilat) lub [simp, intro?]:
  " x ⊑⇩r z; y ⊑⇩r z; x  A; y  A; z  A   x ⊔⇩f y ⊑⇩r z"
  (*<*) by (insert semilat) (unfold semilat_Def, simp) (*>*)

lemma (in Semilat) plus_le_conv [simp]:
  " x  A; y  A; z  A   (x ⊔⇩f y ⊑⇩r z) = (x ⊑⇩r z  y ⊑⇩r z)"
  (*<*) by (blast intro: ub1 ub2 lub order_trans) (*>*)

lemma (in Semilat) le_iff_plus_unchanged:
  assumes "x  A" and "y  A"
  shows "x ⊑⇩r y  x ⊔⇩f y = y" (is "?P  ?Q")
(*<*)
proof
  assume ?P
  with assms show ?Q by (blast intro: antisym_r lub ub2)
next
  assume ?Q
  then have "y = xf y" by simp
  moreover from assms have "xr xf y" by simp
  ultimately show ?P by simp
qed
(*>*)

lemma (in Semilat) le_iff_plus_unchanged2:
  assumes "x  A" and "y  A"
  shows "x ⊑⇩r y  y ⊔⇩f x = y" (is "?P  ?Q")
(*<*)
proof
  assume ?P
  with assms show ?Q by (blast intro: antisym_r lub ub1)
next
  assume ?Q
  then have "y = yf x" by simp
  moreover from assms have "xr yf x" by simp
  ultimately show ?P by simp
qed
(*>*)

lemma (in Semilat) plus_assoc [simp]:
  assumes a: "a  A" and b: "b  A" and c: "c  A"
  shows "a ⊔⇩f (b ⊔⇩f c) = a ⊔⇩f b ⊔⇩f c"
(*<*)
proof -
  from a b have ab: "a ⊔⇩f b  A" ..
  from this c have abc: "(a ⊔⇩f b) ⊔⇩f c  A" ..
  from b c have bc: "b ⊔⇩f c  A" ..
  from a this have abc': "a ⊔⇩f (b ⊔⇩f c)  A" ..

  show ?thesis
  proof    
    show "a ⊔⇩f (b ⊔⇩f c) ⊑⇩r (a ⊔⇩f b) ⊔⇩f c"
    proof -
      from a b have "a ⊑⇩r a ⊔⇩f b" .. 
      also from ab c have " ⊑⇩r  ⊔⇩f c" ..
      finally have "a<": "a ⊑⇩r (a ⊔⇩f b) ⊔⇩f c" .
      from a b have "b ⊑⇩r a ⊔⇩f b" ..
      also from ab c have " ⊑⇩r  ⊔⇩f c" ..
      finally have "b<": "b ⊑⇩r (a ⊔⇩f b) ⊔⇩f c" .
      from ab c have "c<": "c ⊑⇩r (a ⊔⇩f b) ⊔⇩f c" ..    
      from "b<" "c<" b c abc have "b ⊔⇩f c ⊑⇩r (a ⊔⇩f b) ⊔⇩f c" ..
      from "a<" this a bc abc show ?thesis ..
    qed
    show "(a ⊔⇩f b) ⊔⇩f c ⊑⇩r a ⊔⇩f (b ⊔⇩f c)" 
    proof -
      from b c have "b ⊑⇩r b ⊔⇩f c" .. 
      also from a bc have " ⊑⇩r a ⊔⇩f " ..
      finally have "b<": "b ⊑⇩r a ⊔⇩f (b ⊔⇩f c)" .
      from b c have "c ⊑⇩r b ⊔⇩f c" ..
      also from a bc have " ⊑⇩r a ⊔⇩f " ..
      finally have "c<": "c ⊑⇩r a ⊔⇩f (b ⊔⇩f c)" .
      from a bc have "a<": "a ⊑⇩r a ⊔⇩f (b ⊔⇩f c)" ..
      from "a<" "b<" a b abc' have "a ⊔⇩f b ⊑⇩r a ⊔⇩f (b ⊔⇩f c)" ..
      from this "c<" ab c abc' show ?thesis ..
    qed
  qed
qed
(*>*)

lemma (in Semilat) plus_com_lemma:
  "a  A; b  A  a ⊔⇩f b ⊑⇩r b ⊔⇩f a"
(*<*)
proof -
  assume a: "a  A" and b: "b  A"  
  from b a have "a ⊑⇩r b ⊔⇩f a" .. 
  moreover from b a have "b ⊑⇩r b ⊔⇩f a" ..
  moreover note a b
  moreover from b a have "b ⊔⇩f a  A" ..
  ultimately show ?thesis ..
qed
(*>*)

lemma (in Semilat) plus_commutative:
  "a  A; b  A  a ⊔⇩f b = b ⊔⇩f a"
  (*<*) by(blast intro: order_antisym plus_com_lemma) (*>*)

lemma is_lubD:
  "is_lub r x y u  is_ub r x y u  (z. is_ub r x y z  (u,z)  r)"
  (*<*) by (simp add: is_lub_def) (*>*)

lemma is_ubI:
  " (x,u)  r; (y,u)  r   is_ub r x y u"
  (*<*) by (simp add: is_ub_def) (*>*)

lemma is_ubD:
  "is_ub r x y u  (x,u)  r  (y,u)  r"
  (*<*) by (simp add: is_ub_def) (*>*)


lemma is_lub_bigger1 [iff]:  
  "is_lub (r^* ) x y y = ((x,y)r^* )"
(*<*)
  by (unfold is_lub_def is_ub_def) blast
(*>*)

lemma is_lub_bigger2 [iff]:
  "is_lub (r^* ) x y x = ((y,x)r^* )"
(*<*)
  by (unfold is_lub_def is_ub_def) blast 
(*>*)

lemma extend_lub:
  assumes "single_valued r"
    and "is_lub (r*) x y u"
    and "(x', x)  r"
  shows "v. is_lub (r*) x' y v"
(*<*)
proof (cases "(y, x)  r*")
  case True show ?thesis
  proof (cases "(y, x')  r*")
    case True with (y, x)  r* show ?thesis by blast
  next
    case False with True assms show ?thesis
      by (unfold is_lub_def is_ub_def) (blast elim: converse_rtranclE dest: single_valuedD)
  qed
next
  case False
  from assms have "(x', u)  r*" and "(y, u)  r*"
    by (auto simp add: is_lub_def is_ub_def)
  moreover from False assms have "z. (x', z)  r*  (y, z)  r*  (u, z)  r*"
    by (unfold is_lub_def is_ub_def) (blast intro: rtrancl_into_rtrancl
      converse_rtrancl_into_rtrancl elim: converse_rtranclE dest: single_valuedD)
  ultimately have "is_lub (r*) x' y u"
    by (unfold is_lub_def is_ub_def) blast
  then show ?thesis ..
qed
(*>*)

lemma single_valued_has_lubs:
  assumes "single_valued r"
    and in_r: "(x, u)  r*" "(y, u)  r*"
  shows "z. is_lub (r*) x y z"
(*<*)
using in_r proof (induct arbitrary: y rule: converse_rtrancl_induct)
  case base then show ?case by (induct rule: converse_rtrancl_induct)
    (blast, blast intro: converse_rtrancl_into_rtrancl)
next
  case step with ‹single_valued r show ?case by (blast intro: extend_lub)
qed
(*>*)

lemma some_lub_conv:
  " acyclic r; is_lub (r^* ) x y u   some_lub (r^* ) x y = u"
(*<*)
apply (simp only: some_lub_def is_lub_def)
apply (rule someI2)
 apply (simp only: is_lub_def)
apply (blast intro: antisymD dest!: acyclic_impl_antisym_rtrancl)
done
(*>*)

lemma is_lub_some_lub:
  " single_valued r; acyclic r; (x,u)r^*; (y,u)r^*  
   is_lub (r^* ) x y (some_lub (r^* ) x y)"
  (*<*) by (fastforce dest: single_valued_has_lubs simp add: some_lub_conv) (*>*)

subsection‹An executable lub-finder›

definition exec_lub :: "('a * 'a) set  ('a  'a)  'a binop"
where
  "exec_lub r f x y = while (λz. (x,z)  r*) f y"

lemma exec_lub_refl: "exec_lub r f T T = T"
by (simp add: exec_lub_def while_unfold)

lemma acyclic_single_valued_finite:
 "acyclic r; single_valued r; (x,y)  r*
   finite (r  {a. (x, a)  r*} × {b. (b, y)  r*})"
(*<*)
apply(erule converse_rtrancl_induct)
 apply(rule_tac B = "{}" in finite_subset)
  apply(simp only:acyclic_def)
  apply(blast intro:rtrancl_into_trancl2 rtrancl_trancl_trancl)
 apply simp
apply(rename_tac x x')
apply(subgoal_tac "r  {a. (x,a)  r*} × {b. (b,y)  r*} =
                   insert (x,x') (r  {a. (x', a)  r*} × {b. (b, y)  r*})")
 apply simp
apply(blast intro:converse_rtrancl_into_rtrancl
            elim:converse_rtranclE dest:single_valuedD)
done
(*>*)


lemma exec_lub_conv:
  " acyclic r; x y. (x,y)  r  f x = y; is_lub (r*) x y u  
  exec_lub r f x y = u"
(*<*)
apply(unfold exec_lub_def)
apply(rule_tac P = "λz. (y,z)  r*  (z,u)  r*" and
               r = "(r  {(a,b). (y,a)  r*  (b,u)  r*})^-1" in while_rule)
    apply(blast dest: is_lubD is_ubD)
   apply(erule conjE)
   apply(erule_tac z = u in converse_rtranclE)
    apply(blast dest: is_lubD is_ubD)
   apply(blast dest:rtrancl_into_rtrancl)
  apply(rename_tac s)
  apply(subgoal_tac "is_ub (r*) x y s")
   prefer 2 apply(simp add:is_ub_def)
  apply(subgoal_tac "(u, s)  r*")
   prefer 2 apply(blast dest:is_lubD)
  apply(erule converse_rtranclE)
   apply blast
  apply(simp only:acyclic_def)
  apply(blast intro:rtrancl_into_trancl2 rtrancl_trancl_trancl)
 apply(rule finite_acyclic_wf)
  apply simp
  apply(erule acyclic_single_valued_finite)
   apply(blast intro:single_valuedI)
  apply(simp add:is_lub_def is_ub_def)
 apply simp
 apply(erule acyclic_subset)
 apply blast
apply simp
apply(erule conjE)
apply(erule_tac z = u in converse_rtranclE)
 apply(blast dest: is_lubD is_ubD)
apply(blast dest:rtrancl_into_rtrancl)
done
(*>*)

lemma is_lub_exec_lub:
  " single_valued r; acyclic r; (x,u):r^*; (y,u):r^*; x y. (x,y)  r  f x = y 
   is_lub (r^* ) x y (exec_lub r f x y)"
  (*<*) by (fastforce dest: single_valued_has_lubs simp add: exec_lub_conv) (*>*)

end

Theory Err

(*  Title:      HOL/MicroJava/BV/Err.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM

The error type.
*)

section ‹The Error Type›

theory Err
imports Semilat
begin

datatype 'a err = Err | OK 'a

type_synonym 'a ebinop = "'a  'a  'a err"
type_synonym 'a esl = "'a set × 'a ord × 'a ebinop"

primrec ok_val :: "'a err  'a"
where
  "ok_val (OK x) = x"

definition lift :: "('a  'b err)  ('a err  'b err)"
where
  "lift f e = (case e of Err  Err | OK x  f x)"

definition lift2 :: "('a  'b  'c err)  'a err  'b err  'c err"
where
  "lift2 f e1 e2 =
  (case e1 of Err   Err | OK x  (case e2 of Err  Err | OK y  f x y))"

definition le :: "'a ord  'a err ord"
where
  "le r e1 e2 =
  (case e2 of Err  True | OK y  (case e1 of Err  False | OK x  x ⊑⇩r y))"

definition sup :: "('a  'b  'c)  ('a err  'b err  'c err)"
where
  "sup f = lift2 (λx y. OK (x ⊔⇩f y))"

definition err :: "'a set  'a err set"
where
  "err A = insert Err {OK x|x. xA}"

definition esl :: "'a sl  'a esl"
where
  "esl = (λ(A,r,f). (A, r, λx y. OK(f x y)))"

definition sl :: "'a esl  'a err sl"
where
  "sl = (λ(A,r,f). (err A, le r, lift2 f))"

abbreviation
  err_semilat :: "'a esl  bool" where
  "err_semilat L == semilat(sl L)"

primrec strict  :: "('a  'b err)  ('a err  'b err)"
where
  "strict f Err    = Err"
| "strict f (OK x) = f x"

lemma err_def':
  "err A = insert Err {x. yA. x = OK y}"
(*<*)
proof -
  have eq: "err A = insert Err {x. yA. x = OK y}"
    by (unfold err_def) blast
  show "err A = insert Err {x. yA. x = OK y}" by (simp add: eq)
qed
(*>*)

lemma strict_Some [simp]: 
  "(strict f x = OK y) = (z. x = OK z  f z = OK y)"
(*<*) by (cases x, auto) (*>*)

lemma not_Err_eq: "(x  Err) = (a. x = OK a)" 
(*<*) by (cases x) auto (*>*)

lemma not_OK_eq: "(y. x  OK y) = (x = Err)"
(*<*) by (cases x) auto   (*>*)

lemma unfold_lesub_err: "e1le r e2 = le r e1 e2"
(*<*) by (simp add: lesub_def) (*>*)

lemma le_err_refl: "x. x ⊑⇩r x  ele r e"
(*<*)
apply (unfold lesub_def le_def)
apply (simp split: err.split)
done 
(*>*)

lemma le_err_trans [rule_format]:
  "order r  e1le r e2  e2le r e3  e1le r e3"
(*<*)
apply (unfold unfold_lesub_err le_def)
apply (simp split: err.split)
apply (blast intro: order_trans)
done
(*>*)

lemma le_err_antisym [rule_format]:
  "order r  e1le r e2  e2le r e1  e1=e2"
(*<*)
apply (unfold unfold_lesub_err le_def)
apply (simp split: err.split)
apply (blast intro: order_antisym)
done 
(*>*)

lemma OK_le_err_OK: "(OK xle r OK y) = (x ⊑⇩r y)"
(*<*) by (simp add: unfold_lesub_err le_def) (*>*)

lemma order_le_err [iff]: "order(le r) = order r"
(*<*)
apply (rule iffI)
 apply (subst order_def)
 apply (blast dest: order_antisym OK_le_err_OK [THEN iffD2]
              intro: order_trans OK_le_err_OK [THEN iffD1])
apply (subst order_def)
apply (blast intro: le_err_refl le_err_trans le_err_antisym
             dest: order_refl)
done 
(*>*)

lemma le_Err [iff]: "ele r Err"
(*<*) by (simp add: unfold_lesub_err le_def) (*>*)

lemma Err_le_conv [iff]: "Err ⊑le r e  = (e = Err)"
(*<*) by (simp add: unfold_lesub_err le_def  split: err.split) (*>*)

lemma le_OK_conv [iff]: "ele r OK x  =  (y. e = OK y  y ⊑⇩r x)"
(*<*) by (simp add: unfold_lesub_err le_def split: err.split) (*>*)

lemma OK_le_conv: "OK xle r e = (e = Err  (y. e = OK y  x ⊑⇩r y))"
(*<*) by (simp add: unfold_lesub_err le_def split: err.split) (*>*)

lemma top_Err [iff]: "top (le r) Err"
(*<*) by (simp add: top_def) (*>*)

lemma OK_less_conv [rule_format, iff]:
  "OK xle r e = (e=Err  (y. e = OK y  x ⊏⇩r y))"
(*<*) by (simp add: lesssub_def lesub_def le_def split: err.split) (*>*)

lemma not_Err_less [rule_format, iff]: "¬(Err ⊏le r x)"
(*<*) by (simp add: lesssub_def lesub_def le_def split: err.split) (*>*)

lemma semilat_errI [intro]: assumes "Semilat A r f"
shows "semilat(err A, le r, lift2(λx y. OK(f x y)))"
(*<*)
proof -
  interpret Semilat A r f by fact
  show ?thesis
    apply(insert semilat)
    apply (simp only: semilat_Def closed_def plussub_def lesub_def 
              lift2_def le_def)
    apply (simp add: err_def' split: err.split)
    done
qed
(*>*)

lemma err_semilat_eslI_aux:
assumes "Semilat A r f" shows "err_semilat(esl(A,r,f))"
(*<*)
proof -
  interpret Semilat A r f by fact
  show ?thesis
    apply (unfold sl_def esl_def)
    apply (simp add: semilat_errI [OF ‹Semilat A r f])
    done
qed
(*>*)

lemma err_semilat_eslI [intro, simp]:
  "semilat L  err_semilat (esl L)"
(*<*) apply (cases L) apply simp
apply (drule Semilat.intro)
apply (simp add: err_semilat_eslI_aux split_tupled_all)
done (*>*)

lemma acc_err [simp, intro!]:  "acc A r  acc (err A) (le r)"
(*<*)
apply (unfold acc_def lesub_def le_def lesssub_def)
apply (simp add: wf_eq_minimal split: err.split)
apply clarify
apply (case_tac "Err : Q")
 apply blast
apply (erule_tac x = "{a . OK a : Q}" in allE)
apply (case_tac "x")
 apply fast
apply (auto simp: err_def)
done 
(*>*)

lemma Err_in_err [iff]: "Err : err A"
(*<*) by (simp add: err_def') (*>*)

lemma Ok_in_err [iff]: "(OK x  err A) = (xA)"
(*<*) by (auto simp add: err_def') (*>*)

subsection ‹lift›

lemma lift_in_errI:
  " e  err S; xS. e = OK x  f x  err S   lift f e  err S"
(*<*)
apply (unfold lift_def)
apply (simp split: err.split)
apply blast
done 
(*>*)

lemma Err_lift2 [simp]: "Err ⊔lift2 f x = Err"
(*<*) by (simp add: lift2_def plussub_def) (*>*)

lemma lift2_Err [simp]: "xlift2 f Err = Err"
(*<*) by (simp add: lift2_def plussub_def split: err.split) (*>*)

lemma OK_lift2_OK [simp]: "OK xlift2 f OK y = x ⊔⇩f y"
(*<*) by (simp add: lift2_def plussub_def split: err.split) (*>*)


subsection ‹sup›

lemma Err_sup_Err [simp]: "Err ⊔sup f x = Err"
(*<*) by (simp add: plussub_def sup_def lift2_def) (*>*)

lemma Err_sup_Err2 [simp]: "xsup f Err = Err"
(*<*) by (simp add: plussub_def sup_def lift2_def split: err.split) (*>*)

lemma Err_sup_OK [simp]: "OK xsup f OK y = OK (x ⊔⇩f y)"
(*<*) by (simp add: plussub_def sup_def lift2_def) (*>*)

lemma Err_sup_eq_OK_conv [iff]:
  "(sup f ex ey = OK z) = (x y. ex = OK x  ey = OK y  f x y = z)"
(*<*)
apply (unfold sup_def lift2_def plussub_def)
apply (rule iffI)
 apply (simp split: err.split_asm)
apply clarify
apply simp
done
(*>*)

lemma Err_sup_eq_Err [iff]: "(sup f ex ey = Err) = (ex=Err  ey=Err)"
(*<*)
apply (unfold sup_def lift2_def plussub_def)
apply (simp split: err.split)
done 
(*>*)

subsection ‹semilat (err A) (le r) f›

lemma semilat_le_err_Err_plus [simp]:
  " x err A; semilat(err A, le r, f)   Err ⊔⇩f x = Err"
(*<*) by (blast intro: Semilat.le_iff_plus_unchanged [THEN iffD1, OF Semilat.intro] 
                   Semilat.le_iff_plus_unchanged2 [THEN iffD1, OF Semilat.intro]) (*>*)

lemma semilat_le_err_plus_Err [simp]:
  " x err A; semilat(err A, le r, f)   x ⊔⇩f Err = Err"
(*<*) by (blast intro: Semilat.le_iff_plus_unchanged [THEN iffD1, OF Semilat.intro]
                   Semilat.le_iff_plus_unchanged2 [THEN iffD1, OF Semilat.intro]) (*>*)

lemma semilat_le_err_OK1:
  " xA; yA; semilat(err A, le r, f); OK x ⊔⇩f OK y = OK z  
   x ⊑⇩r z"
(*<*)
apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst)
apply (simp add: Semilat.ub1 [OF Semilat.intro])
done
(*>*)

lemma semilat_le_err_OK2:
  " xA; yA; semilat(err A, le r, f); OK x ⊔⇩f OK y = OK z  
   y ⊑⇩r z"
(*<*)
apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst)
apply (simp add: Semilat.ub2 [OF Semilat.intro])
done
(*>*)

lemma eq_order_le:
  " x=y; order r   x ⊑⇩r y"
(*<*)
apply (unfold order_def)
apply blast
done
(*>*)

lemma OK_plus_OK_eq_Err_conv [simp]:
  assumes "xA"  "yA"  "semilat(err A, le r, fe)"
  shows "(OK xfe OK y = Err) = (¬(zA. x ⊑⇩r z  y ⊑⇩r z))"
(*<*)
proof -
  have plus_le_conv3: "A x y z f r. 
     semilat (A,r,f); x ⊔⇩f y ⊑⇩r z; xA; yA; zA  
     x ⊑⇩r z  y ⊑⇩r z"
(*<*) by (rule Semilat.plus_le_conv [OF Semilat.intro, THEN iffD1]) (*>*)
  from assms show ?thesis
  apply (rule_tac iffI)
   apply clarify
   apply (drule OK_le_err_OK [THEN iffD2])
   apply (drule OK_le_err_OK [THEN iffD2])
   apply (drule Semilat.lub[OF Semilat.intro, of _ _ _ "OK x" _ "OK y"])
        apply assumption
       apply assumption
      apply simp
     apply simp
    apply simp
   apply simp
  apply (case_tac "OK xfe OK y")
   apply assumption
  apply (rename_tac z)
  apply (subgoal_tac "OK z err A")
  apply (drule eq_order_le)
    apply (erule Semilat.orderI [OF Semilat.intro])
   apply (blast dest: plus_le_conv3) 
  apply (erule subst)
  apply (blast intro: Semilat.closedI [OF Semilat.intro] closedD)
  done 
qed
(*>*)

subsection ‹semilat (err(Union AS))›

(* FIXME? *)
lemma all_bex_swap_lemma [iff]:
  "(x. (yA. x = f y)  P x) = (yA. P(f y))"
(*<*) by blast (*>*)

lemma closed_err_Union_lift2I: 
  " AAS. closed (err A) (lift2 f); AS  {}; 
      AAS.BAS. AB  (aA.bB. a ⊔⇩f b = Err)  
   closed (err(Union AS)) (lift2 f)"
(*<*)
apply (unfold closed_def err_def')
apply simp
apply clarify
apply simp
apply fast
done 
(*>*)

text ‹
  If @{term "AS = {}"} the thm collapses to
  @{prop "order r  closed {Err} f  Err ⊔⇩f Err = Err"}
  which may not hold 
›
lemma err_semilat_UnionI:
  " AAS. err_semilat(A, r, f); AS  {}; 
      AAS.BAS. AB  (aA.bB. ¬a ⊑⇩r b  a ⊔⇩f b = Err)  
   err_semilat(Union AS, r, f)"
(*<*)
apply (unfold semilat_def sl_def)
apply (simp add: closed_err_Union_lift2I)
apply (rule conjI)
 apply blast
apply (simp add: err_def')
apply (rule conjI)
 apply clarify
 apply (rename_tac A a u B b)
 apply (case_tac "A = B")
  apply simp
 apply simp
apply (rule conjI)
 apply clarify
 apply (rename_tac A a u B b)
 apply (case_tac "A = B")
  apply simp
 apply simp
apply clarify
apply (rename_tac A ya yb B yd z C c a b)
apply (case_tac "A = B")
 apply (case_tac "A = C")
  apply simp
 apply simp
apply (case_tac "B = C")
 apply simp
apply simp
done 
(*>*)

end

Theory Opt

(*  Title:      HOL/MicroJava/BV/Opt.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM

More about options.
*)

section ‹More about Options›

theory Opt
imports
  Err
begin

definition le :: "'a ord  'a option ord"
where
  "le r o1 o2 =
  (case o2 of None  o1=None | Some y  (case o1 of None  True | Some x  x ⊑⇩r y))"

definition opt :: "'a set  'a option set"
where
  "opt A = insert None {Some y |y. y  A}"

definition sup :: "'a ebinop  'a option ebinop"
where
  "sup f o1 o2 =  
  (case o1 of None  OK o2 
           | Some x  (case o2 of None  OK o1
                                 | Some y  (case f x y of Err  Err | OK z  OK (Some z))))"

definition esl :: "'a esl  'a option esl"
where
  "esl = (λ(A,r,f). (opt A, le r, sup f))"


lemma unfold_le_opt:
  "o1le r o2 = 
  (case o2 of None  o1=None | 
              Some y  (case o1 of None  True | Some x  x ⊑⇩r y))"
(*<*)
apply (unfold lesub_def le_def)
apply (rule refl)
done
(*>*)

lemma le_opt_refl: "order r  xle r x"
(*<*) by (simp add: unfold_le_opt split: option.split) (*<*)

lemma le_opt_trans [rule_format]:
  "order r  xle r y  yle r z  xle r z"
(*<*)
apply (simp add: unfold_le_opt split: option.split)
apply (blast intro: order_trans)
done
(*>*)

lemma le_opt_antisym [rule_format]:
  "order r  xle r y  yle r x  x=y"
(*<*)
apply (simp add: unfold_le_opt split: option.split)
apply (blast intro: order_antisym)
done
(*>*)

lemma order_le_opt [intro!,simp]: "order r  order(le r)"
(*<*)
apply (subst order_def)
apply (blast intro: le_opt_refl le_opt_trans le_opt_antisym)
done 
(*>*)

lemma None_bot [iff]:  "None ⊑le r ox"
(*<*)
apply (unfold lesub_def le_def)
apply (simp split: option.split)
done 
(*>*)

lemma Some_le [iff]: "(Some xle r z) = (y. z = Some y  x ⊑⇩r y)"
(*<*)
apply (unfold lesub_def le_def)
apply (simp split: option.split)
done 
(*>*)

lemma le_None [iff]: "(xle r None) = (x = None)"
(*<*)
apply (unfold lesub_def le_def)
apply (simp split: option.split)
done 
(*>*)

lemma OK_None_bot [iff]: "OK None ⊑Err.le (le r) x"
(*<*) by (simp add: lesub_def Err.le_def le_def split: option.split err.split) (*>*)

lemma sup_None1 [iff]: "xsup f None = OK x"
(*<*) by (simp add: plussub_def sup_def split: option.split) (*>*)

lemma sup_None2 [iff]: "None ⊔sup f x = OK x"
(*<*) by (simp add: plussub_def sup_def split: option.split) (*>*)

lemma None_in_opt [iff]: "None  opt A"
(*<*) by (simp add: opt_def) (*>*)

lemma Some_in_opt [iff]: "(Some x  opt A) = (x  A)"
(*<*) by (unfold opt_def) auto (*>*)

lemma semilat_opt [intro, simp]:
  "err_semilat L  err_semilat (Opt.esl L)"
(*<*)
proof -
  assume s: "err_semilat L" 
  obtain A r f where [simp]: "L = (A,r,f)" by (cases L)
  let ?A0 = "err A" and ?r0 = "Err.le r" and ?f0 = "lift2 f"
  from s obtain
    ord: "order ?r0" and
    clo: "closed ?A0 ?f0" and
    ub1: "x?A0. y?A0. x?r0 x?f0 y" and
    ub2: "x?A0. y?A0. y?r0 x?f0 y" and
    lub: "x?A0. y?A0. z?A0. x?r0 z  y?r0 z  x?f0 y?r0 z"
    by (unfold semilat_def sl_def) simp

  let ?A = "err (opt A)" and ?r = "Err.le (Opt.le r)" and ?f = "lift2 (Opt.sup f)"

  from ord have "order ?r" by simp
  moreover
  have "closed ?A ?f"
  proof (unfold closed_def, intro strip)
    fix x y assume x: "x  ?A" and y: "y  ?A" 

    { fix a b assume ab: "x = OK a" "y = OK b"
      with x have a: "c. a = Some c  c  A" by (clarsimp simp add: opt_def)
      from ab y have b: "d. b = Some d  d  A" by (clarsimp simp add: opt_def)      
      { fix c d assume "a = Some c" "b = Some d"
        with ab x y have "c  A & d  A" by (simp add: err_def opt_def Bex_def)
        with clo have "f c d  err A" 
          by (simp add: closed_def plussub_def err_def' lift2_def)
        moreover fix z assume "f c d = OK z"
        ultimately have "z  A" by simp
      } note f_closed = this    
      have "sup f a b  ?A"
      proof (cases a)
        case None thus ?thesis
          by (simp add: sup_def opt_def) (cases b, simp, simp add: b Bex_def)
      next
        case Some thus ?thesis
          by (auto simp add: sup_def opt_def Bex_def a b f_closed split: err.split option.split)
      qed
    }
    thus "x?f y  ?A" by (simp add: plussub_def lift2_def split: err.split)
  qed
  moreover
  { fix a b c assume "a  opt A" and "b  opt A" and "asup f b = OK c" 
    moreover from ord have "order r" by simp
    moreover
    { fix x y z assume "x  A" and "y  A" 
      hence "OK x  err A  OK y  err A" by simp
      with ub1 ub2
      have "(OK x)Err.le r (OK x)lift2 f (OK y) 
            (OK y)Err.le r (OK x)lift2 f (OK y)"
        by blast
      moreover assume "x ⊔⇩f y = OK z"
      ultimately have "x ⊑⇩r z  y ⊑⇩r z"
        by (auto simp add: plussub_def lift2_def Err.le_def lesub_def)
    }
    ultimately have "ale r c  ble r c"
      by (auto simp add: sup_def le_def lesub_def plussub_def 
               dest: order_refl split: option.splits err.splits)
  }     
  hence "(x?A. y?A. x?r x?f y)  (x?A. y?A. y?r x?f y)"
    by (auto simp add: lesub_def plussub_def Err.le_def lift2_def split: err.split)
  moreover
  have "x?A. y?A. z?A. x?r z  y?r z  x?f y?r z"
  proof (intro strip, elim conjE)
    fix x y z
    assume xyz: "x  ?A"   "y  ?A"   "z  ?A"
    assume xz: "x?r z" and yz: "y?r z"
    { fix a b c assume ok: "x = OK a"  "y = OK b"  "z = OK c"
      { fix d e g  assume some: "a = Some d"  "b = Some e"  "c = Some g"
        with ok xyz obtain "OK d:err A" "OK e:err A" "OK g:err A"  by simp
        with lub  
        have " OK dErr.le r OK g; OK eErr.le r OK g   OK dlift2 f OK eErr.le r OK g"
          by blast
        hence " d ⊑⇩r g; e ⊑⇩r g   y. d ⊔⇩f e = OK y  y ⊑⇩r g" by simp
        with ok some xyz xz yz have "x?f y?r z"
          by (auto simp add: sup_def le_def lesub_def lift2_def plussub_def Err.le_def)
      } note this [intro!]
      from ok xyz xz yz have "x?f y?r z"
        by - (cases a, simp, cases b, simp, cases c, simp, blast)
    }    
    with xyz xz yz show "x?f y?r z"
      by - (cases x, simp, cases y, simp, cases z, simp+)
  qed
  ultimately show "err_semilat (Opt.esl L)"
    by (unfold semilat_def esl_def sl_def) simp
qed 
(*>*)

lemma top_le_opt_Some [iff]: "top (le r) (Some T) = top r T"
(*<*)
apply (unfold top_def)
apply (rule iffI)
 apply blast
apply (rule allI)
apply (case_tac "x")
apply simp+
done 
(*>*)

lemma Top_le_conv:  " order r; top r T   (T ⊑⇩r x) = (x = T)"
(*<*)
apply (unfold top_def)
apply (blast intro: order_antisym)
done 
(*>*)


lemma acc_le_optI [intro!]: "acc A r  acc (opt A) (le r)"
(*<*)
apply (unfold acc_def lesub_def le_def lesssub_def)
apply (simp add: wf_eq_minimal split: option.split)
apply clarify
apply (case_tac "a. Some a  Q")
 apply (erule_tac x = "{a . Some a  Q}" in allE)
 apply blast
apply (case_tac "x")
 apply blast
apply blast
done 
(*>*)

lemma map_option_in_optionI:
  " ox  opt S; xS. ox = Some x  f x  S  
   map_option f ox  opt S"
(*<*)
apply (unfold map_option_case)
apply (simp split: option.split)
apply blast
done 
(*>*)

end

Theory Product

(*  Title:      HOL/MicroJava/BV/Product.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM

Products as semilattices.
*)

section ‹Products as Semilattices›

theory Product
imports Err
begin

definition le :: "'a ord  'b ord  ('a × 'b) ord"
where
  "le rA rB = (λ(a1,b1) (a2,b2). a1rA a2  b1rB b2)"

definition sup :: "'a ebinop  'b ebinop  ('a × 'b) ebinop"
where
  "sup f g = (λ(a1,b1)(a2,b2). Err.sup Pair (a1 ⊔⇩f a2) (b1 ⊔⇩g b2))"

definition esl :: "'a esl  'b esl  ('a × 'b ) esl"
where
  "esl = (λ(A,rA,fA) (B,rB,fB). (A × B, le rA rB, sup fA fB))"

abbreviation
  lesubprod :: "'a × 'b  ('a  'a  bool)  ('b  'b  bool)  'a × 'b  bool"
    ("(_ /⊑'(_,_') _)" [50, 0, 0, 51] 50) where
  "p ⊑(rA,rB) q == pProduct.le rA rB q"

(*<*)
notation
  lesubprod  ("(_ /<='(_,_') _)" [50, 0, 0, 51] 50)
(*>*)

lemma unfold_lesub_prod: "x ⊑(rA,rB) y = le rA rB x y"
(*<*) by (simp add: lesub_def) (*>*)

lemma le_prod_Pair_conv [iff]: "((a1,b1) ⊑(rA,rB) (a2,b2)) = (a1rA a2 & b1rB b2)"
(*<*) by (simp add: lesub_def le_def) (*>*)

lemma less_prod_Pair_conv:
  "((a1,b1)Product.le rA rB (a2,b2)) = 
  (a1rA a2 & b1rB b2 | a1rA a2 & b1rB b2)"
(*<*)
apply (unfold lesssub_def)
apply simp
apply blast
done
(*>*)

lemma order_le_prod [iff]: "order(Product.le rA rB) = (order rA & order rB)"
(*<*)
apply (unfold order_def)
apply simp
apply safe
apply blast+
done 
(*>*)


lemma acc_le_prodI [intro!]:
  " acc A rA; acc B rB   acc (A × B) (Product.le rA rB)"
(*<*)
apply (unfold acc_def)
apply (rule wf_subset)
 apply (erule wf_lex_prod)
 apply assumption
apply (auto simp add: lesssub_def less_prod_Pair_conv lex_prod_def)
done
(*>*)


lemma closed_lift2_sup:
  " closed (err A) (lift2 f); closed (err B) (lift2 g)   
  closed (err(A×B)) (lift2(sup f g))"
(*<*)
apply (unfold closed_def plussub_def lift2_def err_def' sup_def)
apply (simp split: err.split)
apply blast
done 
(*>*)

lemma unfold_plussub_lift2: "e1lift2 f e2 = lift2 f e1 e2"
(*<*) by (simp add: plussub_def) (*>*)


lemma plus_eq_Err_conv [simp]:
  assumes "xA"  "yA"  "semilat(err A, Err.le r, lift2 f)"
  shows "(x ⊔⇩f y = Err) = (¬(zA. x ⊑⇩r z  y ⊑⇩r z))"
(*<*)
proof -
  have plus_le_conv2:
    "r f z.  z  err A; semilat (err A, r, f); OK x  err A; OK y  err A;
                 OK x ⊔⇩f OK y ⊑⇩r z  OK x ⊑⇩r z  OK y ⊑⇩r z"
(*<*) by (rule Semilat.plus_le_conv [OF Semilat.intro, THEN iffD1]) (*>*)
  from assms show ?thesis
  apply (rule_tac iffI)
   apply clarify
   apply (drule OK_le_err_OK [THEN iffD2])
   apply (drule OK_le_err_OK [THEN iffD2])
   apply (drule Semilat.lub[OF Semilat.intro, of _ _ _ "OK x" _ "OK y"])
        apply assumption
       apply assumption
      apply simp
     apply simp
    apply simp
   apply simp
  apply (case_tac "x ⊔⇩f y")
   apply assumption
  apply (rename_tac "z")
  apply (subgoal_tac "OK z: err A")
  apply (frule plus_le_conv2)
       apply assumption
      apply simp
      apply blast
     apply simp
    apply (blast dest: Semilat.orderI [OF Semilat.intro] order_refl)
   apply blast
  apply (erule subst)
  apply (unfold semilat_def err_def' closed_def)
  apply simp
  done
qed
(*>*)

lemma err_semilat_Product_esl:
  "L1 L2.  err_semilat L1; err_semilat L2   err_semilat(Product.esl L1 L2)"
(*<*)
apply (unfold esl_def Err.sl_def)
apply (simp (no_asm_simp) only: split_tupled_all)
apply simp
apply (simp (no_asm) only: semilat_Def)
apply (simp (no_asm_simp) only: Semilat.closedI [OF Semilat.intro] closed_lift2_sup)
apply (simp (no_asm) only: unfold_lesub_err Err.le_def unfold_plussub_lift2 sup_def)
apply (auto elim: semilat_le_err_OK1 semilat_le_err_OK2
            simp add: lift2_def  split: err.split)
apply (blast dest: Semilat.orderI [OF Semilat.intro])
apply (blast dest: Semilat.orderI [OF Semilat.intro])

apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst, subst OK_lift2_OK [symmetric], rule Semilat.lub [OF Semilat.intro])
apply simp
apply simp
apply simp
apply simp
apply simp
apply simp

apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst, subst OK_lift2_OK [symmetric], rule Semilat.lub [OF Semilat.intro])
apply simp
apply simp
apply simp
apply simp
apply simp
apply simp
done 
(*>*)

end

Theory Listn

(*  Title:      HOL/MicroJava/BV/Listn.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM

Lists of a fixed length.
*)

section ‹Fixed Length Lists›

theory Listn
imports Err
begin

definition list :: "nat  'a set  'a list set"
where
  "list n A = {xs. size xs = n  set xs  A}"

definition le :: "'a ord  ('a list)ord"
where
  "le r = list_all2 (λx y. x ⊑⇩r y)"

abbreviation
  lesublist :: "'a list  'a ord  'a list  bool"  ("(_ /[⊑⇘_⇙] _)" [50, 0, 51] 50) where
  "x [⊑r] y == x <=_(Listn.le r) y"

abbreviation
  lesssublist :: "'a list  'a ord  'a list  bool"  ("(_ /[⊏⇘_⇙] _)" [50, 0, 51] 50) where
  "x [⊏r] y == x <_(Listn.le r) y"

(*<*)
notation (ASCII)
  lesublist  ("(_ /[<=_] _)" [50, 0, 51] 50) and
  lesssublist  ("(_ /[<_] _)" [50, 0, 51] 50)

abbreviation (input)
  lesublist2 :: "'a list  'a ord  'a list  bool"  ("(_ /[⊑⇩_] _)" [50, 0, 51] 50) where
  "x [⊑⇩r] y == x [⊑r] y"

abbreviation (input)
  lesssublist2 :: "'a list  'a ord  'a list  bool"  ("(_ /[⊏⇩_] _)" [50, 0, 51] 50) where
  "x [⊏⇩r] y == x [⊏r] y"
(*>*)

abbreviation
  plussublist :: "'a list  ('a  'b  'c)  'b list  'c list"
    ("(_ /[⊔⇘_⇙] _)" [65, 0, 66] 65) where
  "x [⊔f] y == xmap2 f y"

(*<*)
notation
  plussublist  ("(_ /[+_] _)" [65, 0, 66] 65)

abbreviation (input)
  plussublist2 :: "'a list  ('a  'b  'c)  'b list  'c list"
    ("(_ /[⊔⇩_] _)" [65, 0, 66] 65) where
  "x [⊔⇩f] y == x [⊔f] y"
(*>*)


primrec coalesce :: "'a err list  'a list err"
where
  "coalesce [] = OK[]"
| "coalesce (ex#exs) = Err.sup (#) ex (coalesce exs)"

definition sl :: "nat  'a sl  'a list sl"
where
  "sl n = (λ(A,r,f). (list n A, le r, map2 f))"

definition sup :: "('a  'b  'c err)  'a list  'b list  'c list err"
where
  "sup f = (λxs ys. if size xs = size ys then coalesce(xs [⊔f] ys) else Err)"

definition upto_esl :: "nat  'a esl  'a list esl"
where
  "upto_esl m = (λ(A,r,f). (Union{list n A |n. n  m}, le r, sup f))"


lemmas [simp] = set_update_subsetI

lemma unfold_lesub_list: "xs [⊑r] ys = Listn.le r xs ys"
(*<*) by (simp add: lesub_def) (*>*)

lemma Nil_le_conv [iff]: "([] [⊑r] ys) = (ys = [])"
(*<*)
apply (unfold lesub_def Listn.le_def)
apply simp
done
(*>*)

lemma Cons_notle_Nil [iff]: "¬ x#xs [⊑r] []"
(*<*)
apply (unfold lesub_def Listn.le_def)
apply simp
done
(*>*)

lemma Cons_le_Cons [iff]: "x#xs [⊑r] y#ys = (x ⊑⇩r y  xs [⊑r] ys)"
(*<*)
by (simp add: lesub_def Listn.le_def)
(*>*)

lemma Cons_less_Conss [simp]:
  "order r   x#xs [⊏⇩r] y#ys = (x ⊏⇩r y  xs [⊑r] ys  x = y  xs [⊏⇩r] ys)"
(*<*)
apply (unfold lesssub_def)
apply blast
done
(*>*)

lemma list_update_le_cong:
  " i<size xs; xs [⊑r] ys; x ⊑⇩r y   xs[i:=x] [⊑r] ys[i:=y]"
(*<*)
apply (unfold unfold_lesub_list)
apply (unfold Listn.le_def)
apply (simp add: list_all2_update_cong)
done
(*>*)


lemma le_listD: " xs [⊑r] ys; p < size xs   xs!p ⊑⇩r ys!p"
(*<*)
by (simp add: Listn.le_def lesub_def list_all2_nthD)
(*>*)

lemma le_list_refl: "x. x ⊑⇩r x  xs [⊑r] xs"
(*<*)
apply (simp add: unfold_lesub_list lesub_def Listn.le_def list_all2_refl)
done
(*>*)

lemma le_list_trans: " order r; xs [⊑r] ys; ys [⊑r] zs   xs [⊑r] zs"
(*<*)
apply (unfold unfold_lesub_list)
apply (unfold Listn.le_def)
apply (rule list_all2_trans)
apply (erule order_trans)
apply assumption+
done
(*>*)

lemma le_list_antisym: " order r; xs [⊑r] ys; ys [⊑r] xs   xs = ys"
(*<*)
apply (unfold unfold_lesub_list)
apply (unfold Listn.le_def)
apply (rule list_all2_antisym)
apply (rule order_antisym)
apply assumption+
done
(*>*)

lemma order_listI [simp, intro!]: "order r  order(Listn.le r)"
(*<*)
apply (subst order_def)
apply (blast intro: le_list_refl le_list_trans le_list_antisym
             dest: order_refl)
done
(*>*)

lemma lesub_list_impl_same_size [simp]: "xs [⊑r] ys  size ys = size xs"
(*<*)
apply (unfold Listn.le_def lesub_def)
apply (simp add: list_all2_lengthD)
done
(*>*)

lemma lesssub_lengthD: "xs [⊏⇩r] ys  size ys = size xs"
(*<*)
apply (unfold lesssub_def)
apply auto
done
(*>*)

lemma le_list_appendI: "a [⊑r] b  c [⊑r] d  a@c [⊑r] b@d"
(*<*)
apply (unfold Listn.le_def lesub_def)
apply (rule list_all2_appendI, assumption+)
done
(*>*)

lemma le_listI:
  assumes "length a = length b"
  assumes "n. n < length a  a!n ⊑⇩r b!n"
  shows "a [⊑r] b"
(*<*)
proof -
  from assms have "list_all2 r a b"
    by (simp add: list_all2_all_nthI lesub_def)
  then show ?thesis by (simp add: Listn.le_def lesub_def)
qed
(*>*)

lemma listI: " size xs = n; set xs  A   xs  list n A"
(*<*)
apply (unfold list_def)
apply blast
done
(*>*)

(* FIXME: remove simp *)
lemma listE_length [simp]: "xs  list n A  size xs = n"
(*<*)
apply (unfold list_def)
apply blast
done
(*>*)

lemma less_lengthI: " xs  list n A; p < n   p < size xs"
(*<*) by simp (*>*)

lemma listE_set [simp]: "xs  list n A  set xs  A"
(*<*)
apply (unfold list_def)
apply blast
done
(*>*)

lemma list_0 [simp]: "list 0 A = {[]}"
(*<*)
apply (unfold list_def)
apply auto
done
(*>*)

lemma in_list_Suc_iff:
  "(xs  list (Suc n) A) = (yA. ys  list n A. xs = y#ys)"
(*<*)
apply (unfold list_def)
apply (case_tac "xs")
apply auto
done
(*>*)

lemma Cons_in_list_Suc [iff]:
  "(x#xs  list (Suc n) A) = (xA  xs  list n A)"
(*<*)
apply (simp add: in_list_Suc_iff)
done
(*>*)

lemma list_not_empty:
  "a. aA  xs. xs  list n A"
(*<*)
apply (induct "n")
 apply simp
apply (simp add: in_list_Suc_iff)
apply blast
done
(*>*)


lemma nth_in [rule_format, simp]:
  "i n. size xs = n  set xs  A  i < n  (xs!i)  A"
(*<*)
apply (induct "xs")
 apply simp
apply (simp add: nth_Cons split: nat.split)
done
(*>*)

lemma listE_nth_in: " xs  list n A; i < n   xs!i  A"
(*<*) by auto (*>*)

lemma listn_Cons_Suc [elim!]:
  "l#xs  list n A  (n'. n = Suc n'  l  A  xs  list n' A  P)  P"
(*<*) by (cases n) auto (*>*)

lemma listn_appendE [elim!]:
  "a@b  list n A  (n1 n2. n=n1+n2  a  list n1 A  b  list n2 A  P)  P"
(*<*)
proof -
  have "n. a@b  list n A  n1 n2. n=n1+n2  a  list n1 A  b  list n2 A"
    (is "n. ?list a n  n1 n2. ?P a n n1 n2")
  proof (induct a)
    fix n assume "?list [] n"
    hence "?P [] n 0 n" by simp
    thus "n1 n2. ?P [] n n1 n2" by fast
  next
    fix n l ls
    assume "?list (l#ls) n"
    then obtain n' where n: "n = Suc n'" "l  A" and n': "ls@b  list n' A" by fastforce
    assume "n. ls @ b  list n A  n1 n2. n = n1 + n2  ls  list n1 A  b  list n2 A"
    from this and n' have "n1 n2. n' = n1 + n2  ls  list n1 A  b  list n2 A" .
    then obtain n1 n2 where "n' = n1 + n2" "ls  list n1 A" "b  list n2 A" by fast
    with n have "?P (l#ls) n (n1+1) n2" by simp
    thus "n1 n2. ?P (l#ls) n n1 n2" by fastforce
  qed
  moreover
  assume "a@b  list n A" "n1 n2. n=n1+n2  a  list n1 A  b  list n2 A  P"
  ultimately
  show ?thesis by blast
qed
(*>*)


lemma listt_update_in_list [simp, intro!]:
  " xs  list n A; xA   xs[i := x]  list n A"
(*<*)
apply (unfold list_def)
apply simp
done
(*>*)

lemma list_appendI [intro?]:
  " a  list n A; b  list m A   a @ b  list (n+m) A"
(*<*) by (unfold list_def) auto (*>*)

lemma list_map [simp]: "(map f xs  list (size xs) A) = (f ` set xs  A)"
(*<*) by (unfold list_def) simp (*>*)

lemma list_replicateI [intro]: "x  A  replicate n x  list n A"
(*<*) by (induct n) auto (*>*)

lemma plus_list_Nil [simp]: "[] [⊔f] xs = []"
(*<*)
apply (unfold plussub_def)
apply simp
done
(*>*)

lemma plus_list_Cons [simp]:
  "(x#xs) [⊔f] ys = (case ys of []  [] | y#ys  (x ⊔⇩f y)#(xs [⊔f] ys))"
(*<*) by (simp add: plussub_def split: list.split) (*>*)

lemma length_plus_list [rule_format, simp]:
  "ys. size(xs [⊔f] ys) = min(size xs) (size ys)"
(*<*)
apply (induct xs)
 apply simp
apply clarify
apply (simp (no_asm_simp) split: list.split)
done
(*>*)

lemma nth_plus_list [rule_format, simp]:
  "xs ys i. size xs = n  size ys = n  i<n  (xs [⊔f] ys)!i = (xs!i) ⊔⇩f (ys!i)"
(*<*)
apply (induct n)
 apply simp
apply clarify
apply (case_tac xs)
 apply simp
apply (force simp add: nth_Cons split: list.split nat.split)
done
(*>*)


lemma (in Semilat) plus_list_ub1 [rule_format]:
 " set xs  A; set ys  A; size xs = size ys 
   xs [⊑r] xs [⊔f] ys"
(*<*)
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
done
(*>*)

lemma (in Semilat) plus_list_ub2:
 "set xs  A; set ys  A; size xs = size ys   ys [⊑r] xs [⊔f] ys"
(*<*)
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
done
(*>*)

lemma (in Semilat) plus_list_lub [rule_format]:
shows "xs ys zs. set xs  A  set ys  A  set zs  A
   size xs = n  size ys = n 
  xs [⊑r] zs  ys [⊑r] zs  xs [⊔f] ys [⊑r] zs"
(*<*)
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
done
(*>*)

lemma (in Semilat) list_update_incr [rule_format]:
 "xA  set xs  A 
  (i. i<size xs  xs [⊑r] xs[i := x ⊔⇩f xs!i])"
(*<*)
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
apply (induct xs)
 apply simp
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp add: nth_Cons split: nat.split)
done
(*>*)

lemma acc_le_listI' [intro!]:
  " order r; acc A r   acc (n. list n A) (Listn.le r)"
(*<*)
apply (unfold acc_def)
apply (subgoal_tac
 "wf(UN n. {(ys,xs). xs  list n A  ys  list n A  xs <_(Listn.le r) ys})")
 apply (erule wf_subset)
 apply clarify
 apply(rule UN_I)
  prefer 2
  apply clarify
  apply(frule lesssub_lengthD)
  apply fastforce
 apply simp
apply (rule wf_UN)
 prefer 2
 apply (rename_tac m n)
 apply (case_tac "m=n")
  apply simp
 apply (clarsimp intro!: equals0I)
 apply (drule lesssub_lengthD)+
 apply simp
apply (induct_tac n)
 apply (simp add: lesssub_def cong: conj_cong)
apply (rename_tac k)
apply (simp add: wf_eq_minimal)
apply (simp (no_asm) add: in_list_Suc_iff cong: conj_cong)
apply clarify
apply (rename_tac M m)
apply (case_tac "xA. xslist k A. x#xs  M")
 prefer 2
 apply (erule thin_rl)
 apply (erule thin_rl)
 apply blast
apply (erule_tac x = "{a. a  A  (xslist k A. a#xsM)}" in allE)
apply (erule impE)
 apply blast
apply (thin_tac "xA. xslist k A. P x xs" for P)
apply clarify
apply (rename_tac maxA xs)
apply (erule_tac x = "{ys. ys  list k A  maxA#ys  M}" in allE)
apply (erule impE)
 apply blast
apply clarify
apply (thin_tac "m  M")
apply (thin_tac "maxA#xs  M")
apply (rule bexI)
 prefer 2
 apply assumption
apply clarify
apply simp
apply (erule disjE)
 prefer 2
 apply blast
by fastforce

lemma acc_le_listI [intro!]:
  " order r; acc A r   acc (list n A) (Listn.le r)"
apply(drule (1) acc_le_listI')
apply(erule thin_rl)
apply(unfold acc_def)
apply(erule wf_subset)
apply blast
done

lemma acc_le_list_uptoI [intro!]:
  " order r; acc A r   acc ({list n A|n. n  mxs}) (Listn.le r)"
apply(drule (1) acc_le_listI')
apply(erule thin_rl)
apply(unfold acc_def)
apply(erule wf_subset)
apply blast
done

lemma closed_listI:
  "closed S f  closed (list n S) (map2 f)"
(*<*)
apply (unfold closed_def)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply simp
done
(*>*)


lemma Listn_sl_aux:
assumes "Semilat A r f" shows "semilat (Listn.sl n (A,r,f))"
(*<*)
proof -
  interpret Semilat A r f by fact
  show ?thesis
  apply (unfold Listn.sl_def)
  apply (simp (no_asm) only: semilat_Def split_conv)
  apply (rule conjI)
   apply simp
  apply (rule conjI)
   apply (simp only: closedI closed_listI)
  apply (simp (no_asm) only: list_def)
  apply (simp (no_asm_simp) add: plus_list_ub1 plus_list_ub2 plus_list_lub)
  done
qed
(*>*)

lemma Listn_sl: "semilat L  semilat (Listn.sl n L)"
(*<*) apply (cases L) apply simp
apply (drule Semilat.intro)
by (simp add: Listn_sl_aux split_tupled_all) (*>*)

lemma coalesce_in_err_list [rule_format]:
  "xes. xes  list n (err A)  coalesce xes  err(list n A)"
(*<*)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp (no_asm) add: plussub_def Err.sup_def lift2_def split: err.split)
apply force
done
(*>*)

lemma lem: "x xs. x(#) xs = x#xs"
(*<*) by (simp add: plussub_def) (*>*)

lemma coalesce_eq_OK1_D [rule_format]:
  "semilat(err A, Err.le r, lift2 f) 
  xs. xs  list n A  (ys. ys  list n A 
  (zs. coalesce (xs [⊔f] ys) = OK zs  xs [⊑r] zs))"
(*<*)
apply (induct n)
  apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
apply (force simp add: semilat_le_err_OK1)
done
(*>*)

lemma coalesce_eq_OK2_D [rule_format]:
  "semilat(err A, Err.le r, lift2 f) 
  xs. xs  list n A  (ys. ys  list n A 
  (zs. coalesce (xs [⊔f] ys) = OK zs  ys [⊑r] zs))"
(*<*)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
apply (force simp add: semilat_le_err_OK2)
done
(*>*)

lemma lift2_le_ub:
  " semilat(err A, Err.le r, lift2 f); xA; yA; x ⊔⇩f y = OK z;
      uA; x ⊑⇩r u; y ⊑⇩r u   z ⊑⇩r u"
(*<*)
apply (unfold semilat_Def plussub_def err_def')
apply (simp add: lift2_def)
apply clarify
apply (rotate_tac -3)
apply (erule thin_rl)
apply (erule thin_rl)
apply force
done
(*>*)

lemma coalesce_eq_OK_ub_D [rule_format]:
  "semilat(err A, Err.le r, lift2 f) 
  xs. xs  list n A  (ys. ys  list n A 
  (zs us. coalesce (xs [⊔f] ys) = OK zs  xs [⊑r] us  ys [⊑r] us
            us  list n A  zs [⊑r] us))"
(*<*)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp (no_asm_use) split: err.split_asm add: lem Err.sup_def lift2_def)
apply clarify
apply (rule conjI)
 apply (blast intro: lift2_le_ub)
apply blast
done
(*>*)

lemma lift2_eq_ErrD:
  " x ⊔⇩f y = Err; semilat(err A, Err.le r, lift2 f); xA; yA 
   ¬(uA. x ⊑⇩r u  y ⊑⇩r u)"
(*<*) by (simp add: OK_plus_OK_eq_Err_conv [THEN iffD1]) (*>*)


lemma coalesce_eq_Err_D [rule_format]:
  " semilat(err A, Err.le r, lift2 f) 
   xs. xs  list n A  (ys. ys  list n A 
      coalesce (xs [⊔f] ys) = Err 
      ¬(zs  list n A. xs [⊑r] zs  ys [⊑r] zs))"
(*<*)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
 apply (blast dest: lift2_eq_ErrD)
done
(*>*)

lemma closed_err_lift2_conv:
  "closed (err A) (lift2 f) = (xA. yA. x ⊔⇩f y  err A)"
(*<*)
apply (unfold closed_def)
apply (simp add: err_def')
done
(*>*)

lemma closed_map2_list [rule_format]:
  "closed (err A) (lift2 f) 
  xs. xs  list n A  (ys. ys  list n A 
  map2 f xs ys  list n (err A))"
(*<*)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp add: plussub_def closed_err_lift2_conv)
done
(*>*)

lemma closed_lift2_sup:
  "closed (err A) (lift2 f) 
  closed (err (list n A)) (lift2 (sup f))"
(*<*) by (fastforce  simp add: closed_def plussub_def sup_def lift2_def
                          coalesce_in_err_list closed_map2_list
                split: err.split) (*>*)

lemma err_semilat_sup:
  "err_semilat (A,r,f) 
  err_semilat (list n A, Listn.le r, sup f)"
(*<*)
apply (unfold Err.sl_def)
apply (simp only: split_conv)
apply (simp (no_asm) only: semilat_Def plussub_def)
apply (simp (no_asm_simp) only: Semilat.closedI [OF Semilat.intro] closed_lift2_sup)
apply (rule conjI)
 apply (drule Semilat.orderI [OF Semilat.intro])
 apply simp
apply (simp (no_asm) only: unfold_lesub_err Err.le_def err_def' sup_def lift2_def)
apply (simp (no_asm_simp) add: coalesce_eq_OK1_D coalesce_eq_OK2_D split: err.split)
apply (blast intro: coalesce_eq_OK_ub_D dest: coalesce_eq_Err_D)
done
(*>*)

lemma err_semilat_upto_esl:
  "L. err_semilat L  err_semilat(upto_esl m L)"
(*<*)
apply (unfold Listn.upto_esl_def)
apply (simp (no_asm_simp) only: split_tupled_all)
apply simp
apply (fastforce intro!: err_semilat_UnionI err_semilat_sup
                dest: lesub_list_impl_same_size
                simp add: plussub_def Listn.sup_def)
done
(*>*)

end

Theory Semilattices

(*  Title:      HOL/MicroJava/BV/Semilat.thy
    Author:     Gerwin Klein
    Copyright   2003 TUM

Semilattices.
*)
(*<*)
theory Semilattices
imports Err Opt Product Listn
begin

end
(*>*)

Theory Typing_Framework

(*  Title:      HOL/MicroJava/BV/Typing_Framework.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM
*)

section ‹Typing and Dataflow Analysis Framework›

theory Typing_Framework
imports
  Semilattices
begin

text ‹
  The relationship between dataflow analysis and a welltyped-instruction predicate. 
›
type_synonym
  's step_type = "nat  's  (nat × 's) list"

definition stable :: "'s ord  's step_type  's list  nat  bool"
where
  "stable r step τs p  ((q,τ)  set (step p (τs!p)). τ ⊑⇩r τs!q)"

definition stables :: "'s ord  's step_type  's list  bool"
where
  "stables r step τs  (p < size τs. stable r step τs p)"

definition wt_step :: "'s ord  's  's step_type  's list  bool"
where
  "wt_step r T step τs  (p<size τs. τs!p  T  stable r step τs p)"

definition is_bcv :: "'s ord  's  's step_type  nat  's set  ('s list  's list)  bool"
where
  "is_bcv r T step n A bcv  (τs0  list n A.
  (p<n. (bcv τs0)!p  T) = (τs  list n A. τs0 [⊑⇩r] τs  wt_step r T step τs))"

end

Theory SemilatAlg

(*  Title:      HOL/MicroJava/BV/SemilatAlg.thy
    Author:     Gerwin Klein
    Copyright   2002 Technische Universitaet Muenchen
*)

section ‹More on Semilattices›

theory SemilatAlg
imports Typing_Framework
begin

definition lesubstep_type :: "(nat × 's) set  's ord  (nat × 's) set  bool"
    ("(_ /{⊑⇘_⇙} _)" [50, 0, 51] 50)
  where "A {⊑r} B  (p,τ)  A. τ'. (p,τ')  B  τ ⊑⇩r τ'"

notation (ASCII)
  lesubstep_type  ("(_ /{<='__} _)" [50, 0, 51] 50)

primrec pluslussub :: "'a list  ('a  'a  'a)  'a  'a"  ("(_ /⨆⇘_ _)" [65, 0, 66] 65)
where
  "pluslussub [] f y = y"
| "pluslussub (x#xs) f y = pluslussub xs f (x ⊔⇩f y)"
(*<*)
notation (ASCII)
  pluslussub  ("(_ /++'__ _)" [65, 1000, 66] 65)
(*>*)

definition bounded :: "'s step_type  nat  bool"
where
  "bounded step n  (p<n. τ. (q,τ')  set (step p τ). q<n)"

definition pres_type :: "'s step_type  nat  's set  bool"
where
  "pres_type step n A  (τA. p<n. (q,τ')  set (step p τ). τ'  A)"

definition mono :: "'s ord  's step_type  nat  's set  bool"
where
  "mono r step n A 
    (τ p τ'. τ  A  p<n  τ ⊑⇩r τ'  set (step p τ) {⊑r} set (step p τ'))"

lemma [iff]: "{} {⊑r} B" 
  (*<*) by (simp add: lesubstep_type_def) (*>*)

lemma [iff]: "(A {⊑r} {}) = (A = {})"
  (*<*) by (cases "A={}") (auto simp add: lesubstep_type_def) (*>*)

lemma lesubstep_union:
  " A1 {⊑r} B1; A2 {⊑r} B2   A1  A2 {⊑r} B1  B2"
  (*<*) by (auto simp add: lesubstep_type_def) (*>*)

lemma pres_typeD:
  " pres_type step n A; sA; p<n; (q,s')set (step p s)   s'  A"
(*<*) by (unfold pres_type_def, blast) (*>*)

lemma monoD:
  " mono r step n A; p < n; sA; s ⊑⇩r t   set (step p s) {⊑r} set (step p t)"
(*<*) by (unfold mono_def, blast) (*>*)

lemma boundedD: 
  " bounded step n; p < n; (q,t)  set (step p xs)   q < n" 
(*<*) by (unfold bounded_def, blast) (*>*)

lemma lesubstep_type_refl [simp, intro]:
  "(x. x ⊑⇩r x)  A {⊑r} A"
(*<*) by (unfold lesubstep_type_def) auto (*>*)

lemma lesub_step_typeD:
  "A {⊑r} B  (x,y)  A  y'. (x, y')  B  y ⊑⇩r y'"
(*<*) by (unfold lesubstep_type_def) blast (*>*)


lemma list_update_le_listI [rule_format]:
  "set xs  A  set ys  A  xs [⊑⇩r] ys  p < size xs   
   x ⊑⇩r ys!p  semilat(A,r,f)  xA  
   xs[p := x ⊔⇩f xs!p] [⊑⇩r] ys"
(*<*)
  apply (simp only: Listn.le_def lesub_def semilat_def)
  apply (simp add: list_all2_conv_all_nth nth_list_update)
  done
(*>*)

lemma plusplus_closed: assumes "Semilat A r f" shows
  "y.  set x  A; y  A  xf y  A"
(*<*)
proof (induct x)
  interpret Semilat A r f by fact
  show "y. y  A  []f y  A" by simp
  fix y x xs
  assume y: "y  A" and xxs: "set (x#xs)  A"
  assume IH: "y.  set xs  A; y  A  xsf y  A"
  from xxs obtain x: "x  A" and xs: "set xs  A" by simp
  from x y have "xf y  A" ..
  with xs have "xsf (xf y)  A" by (rule IH)
  thus "x#xsf y  A" by simp
qed
(*>*)

lemma (in Semilat) pp_ub2:
 "y.  set x  A; y  A  yr xf y"
(*<*)
proof (induct x)
  from semilat show "y. yr []f y" by simp
  
  fix y a l assume y:  "y  A" and "set (a#l)  A"
  then obtain a: "a  A" and x: "set l  A" by simp
  assume "y. set l  A; y  A  yr lf y"
  from this and x have IH: "y. y  A  yr lf y" .

  from a y have "yr af y" ..
  also from a y have "af y  A" ..
  hence "(af y)r lf (af y)" by (rule IH)
  finally have "yr lf (af y)" .
  thus "yr (a#l)f y" by simp
qed
(*>*)


lemma (in Semilat) pp_ub1:
shows "y. set ls  A; y  A; x  set ls  xr lsf y"
(*<*)
proof (induct ls)
  show "y. x  set []  xr []f y" by simp

  fix y s ls
  assume "set (s#ls)  A"
  then obtain s: "s  A" and ls: "set ls  A" by simp
  assume y: "y  A" 

  assume "y. set ls  A; y  A; x  set ls  xr lsf y"
  from this and ls have IH: "y. x  set ls  y  A  xr lsf y" .

  assume "x  set (s#ls)"
  then obtain xls: "x = s  x  set ls" by simp
  moreover {
    assume xs: "x = s"
    from s y have "sr sf y" ..
    also from s y have "sf y  A" ..
    with ls have "(sf y)r lsf (sf y)" by (rule pp_ub2)
    finally have "sr lsf (sf y)" .
    with xs have "xr lsf (sf y)" by simp
  } 
  moreover {
    assume "x  set ls"
    hence "y. y  A  xr lsf y" by (rule IH)
    moreover from s y have "sf y  A" ..
    ultimately have "xr lsf (sf y)" .
  }
  ultimately 
  have "xr lsf (sf y)" by blast
  thus "xr (s#ls)f y" by simp
qed
(*>*)


lemma (in Semilat) pp_lub:
  assumes z: "z  A"
  shows 
  "y. y  A  set xs  A  x  set xs. xr z  yr z  xsf yr z"
(*<*)
proof (induct xs)
  fix y assume "yr z" thus "[]f yr z" by simp
next
  fix y l ls assume y: "y  A" and "set (l#ls)  A"
  then obtain l: "l  A" and ls: "set ls  A" by auto
  assume "x  set (l#ls). xr z"
  then obtain lz: "lr z" and lsz: "x  set ls. xr z" by auto
  assume "yr z" with lz have "lf yr z" using l y z ..
  moreover
  from l y have "lf y  A" ..
  moreover
  assume "y. y  A  set ls  A  x  set ls. xr z  yr z
           lsf yr z"
  ultimately
  have "lsf (lf y)r z" using ls lsz by -
  thus "(l#ls)f yr z" by simp
qed
(*>*)


lemma ub1': assumes "Semilat A r f"
shows "(p,s)  set S. s  A; y  A; (a,b)  set S 
   br map snd [(p', t')  S. p' = a]f y" 
(*<*)
proof -
  interpret Semilat A r f by fact
  let "br ?mapf y" = ?thesis

  assume "y  A"
  moreover
  assume "(p,s)  set S. s  A"
  hence "set ?map  A" by auto
  moreover
  assume "(a,b)  set S"
  hence "b  set ?map" by (induct S, auto)
  ultimately
  show ?thesis by - (rule pp_ub1)
qed
(*>*)
    
 
lemma plusplus_empty:  
  "s'. (q, s')  set S  s'f ss ! q = ss ! q 
   (map snd [(p', t')  S. p' = q]f ss ! q) = ss ! q"
(*<*)
apply (induct S)
apply auto 
done
(*>*)


end

Theory Typing_Framework_err

(*  Title:      HOL/MicroJava/BV/Typing_Framework_err.thy
    Author:     Gerwin Klein
    Copyright   2000 TUM
*)

section ‹Lifting the Typing Framework to err, app, and eff›

theory Typing_Framework_err
imports
  Typing_Framework
  SemilatAlg
begin

definition wt_err_step :: "'s ord  's err step_type  's err list  bool"
where
  "wt_err_step r step τs  wt_step (Err.le r) Err step τs"

definition wt_app_eff :: "'s ord  (nat  's  bool)  's step_type  's list  bool"
where
  "wt_app_eff r app step τs 
    (p < size τs. app p (τs!p)  ((q,τ)  set (step p (τs!p)). τ <=_r τs!q))"

definition map_snd :: "('b  'c)  ('a × 'b) list  ('a × 'c) list"
where
  "map_snd f = map (λ(x,y). (x, f y))"

definition error :: "nat  (nat × 'a err) list"
where
  "error n = map (λx. (x,Err)) [0..<n]"

definition err_step :: "nat  (nat  's  bool)  's step_type  's err step_type"
where
  "err_step n app step p t = 
  (case t of 
    Err    error n
  | OK τ  if app p τ then map_snd OK (step p τ) else error n)"

definition app_mono :: "'s ord  (nat  's  bool)  nat  's set  bool"
where
  "app_mono r app n A 
    (s p t. s  A  p < n  s ⊑⇩r t  app p t  app p s)"


lemmas err_step_defs = err_step_def map_snd_def error_def


lemma bounded_err_stepD:
  " bounded (err_step n app step) n;
     p < n; app p a; (q,b)  set (step p a)   q < n"
(*<*)
  apply (simp add: bounded_def err_step_def)
  apply (erule allE, erule impE, assumption)
  apply (erule_tac x = "OK a" in allE, drule bspec)
   apply (simp add: map_snd_def)
   apply fast
  apply simp
  done
(*>*)


lemma in_map_sndD: "(a,b)  set (map_snd f xs)  b'. (a,b')  set xs"
(*<*)
  apply (induct xs)
  apply (auto simp add: map_snd_def)
  done
(*>*)


lemma bounded_err_stepI:
  "p. p < n  (s. ap p s  ((q,s')  set (step p s). q < n))
   bounded (err_step n ap step) n"
(*<*)
apply (clarsimp simp: bounded_def err_step_def split: err.splits)
apply (simp add: error_def image_def)
apply (blast dest: in_map_sndD)
done
(*>*)


lemma bounded_lift:
  "bounded step n  bounded (err_step n app step) n"
(*<*)
  apply (unfold bounded_def err_step_def error_def)
  apply clarify
  apply (erule allE, erule impE, assumption)
  apply (case_tac τ)
  apply (auto simp add: map_snd_def split: if_split_asm)
  done
(*>*)


lemma le_list_map_OK [simp]:
  "b. (map OK a [⊑Err.le r] map OK b) = (a [⊑⇩r] b)"
(*<*)
  apply (induct a)
   apply simp
  apply simp
  apply (case_tac b)
   apply simp
  apply simp
  done
(*>*)


lemma map_snd_lessI:
  "set xs {⊑r} set ys  set (map_snd OK xs) {⊑Err.le r} set (map_snd OK ys)"
(*<*)
  apply (induct xs)
  apply (unfold lesubstep_type_def map_snd_def)
  apply auto
  done
(*>*)


lemma mono_lift:
  " order r; app_mono r app n A; bounded (err_step n app step) n;
    s p t. s  A  p < n  s ⊑⇩r t  app p t  set (step p s) {⊑r} set (step p t) 
    mono (Err.le r) (err_step n app step) n (err A)"
(*<*)
apply (simp only: app_mono_def SemilatAlg.mono_def err_step_def)
apply clarify
apply (case_tac τ)
 apply simp 
apply simp
apply (case_tac τ')
 apply simp
 apply clarify
 apply (simp add: lesubstep_type_def error_def)
 apply clarify
 apply (drule in_map_sndD)
 apply clarify
 apply (drule bounded_err_stepD, assumption+)
 apply (rule exI [of _ Err])
 apply simp
apply simp
apply (erule allE, erule allE, erule allE, erule impE)
 apply (rule conjI, assumption)
 apply (rule conjI, assumption)
 apply assumption
apply (rule conjI)
apply clarify
apply (erule allE, erule allE, erule allE, erule impE)
 apply (rule conjI, assumption)
 apply (rule conjI, assumption)
 apply assumption
apply (erule impE, assumption)
apply (rule map_snd_lessI, assumption)
apply clarify
apply (simp add: lesubstep_type_def error_def)
apply clarify
apply (drule in_map_sndD)
apply clarify
apply (drule bounded_err_stepD, assumption+)
apply (rule exI [of _ Err])
apply simp
done
(*>*)
 
lemma in_errorD: "(x,y)  set (error n)  y = Err"
(*<*) by (auto simp add: error_def) (*>*)

lemma pres_type_lift:
  "sA. p. p < n  app p s  ((q, s')set (step p s). s'  A) 
   pres_type (err_step n app step) n (err A)"  
(*<*)
apply (unfold pres_type_def err_step_def)
apply clarify
apply (case_tac b)
 apply simp
apply (case_tac τ)
 apply simp
 apply (drule in_errorD)
 apply simp
apply (simp add: map_snd_def split: if_split_asm)
 apply fast
apply (drule in_errorD)
apply simp
done
(*>*)


lemma wt_err_imp_wt_app_eff:
  assumes wt: "wt_err_step r (err_step (size ts) app step) ts"
  assumes b:  "bounded (err_step (size ts) app step) (size ts)"
  shows "wt_app_eff r app step (map ok_val ts)"
(*<*)
proof (unfold wt_app_eff_def, intro strip, rule conjI)
  fix p assume "p < size (map ok_val ts)"
  hence lp: "p < size ts" by simp
  hence ts: "0 < size ts" by (cases p) auto
  hence err: "(0,Err)  set (error (size ts))" by (simp add: error_def)

  from wt lp
  have [intro?]: "p. p < size ts  ts ! p  Err" 
    by (unfold wt_err_step_def wt_step_def) simp

  show app: "app p (map ok_val ts ! p)"
  proof (rule ccontr)
    from wt lp obtain s where
      OKp:  "ts ! p = OK s" and
      less: "(q,t)  set (err_step (size ts) app step p (ts!p)). t <=_(Err.le r) ts!q"
      by (unfold wt_err_step_def wt_step_def stable_def) 
         (auto iff: not_Err_eq)
    assume "¬ app p (map ok_val ts ! p)"
    with OKp lp have "¬ app p s" by simp
    with OKp have "err_step (size ts) app step p (ts!p) = error (size ts)" 
      by (simp add: err_step_def)    
    with err ts obtain q where 
      "(q,Err)  set (err_step (size ts) app step p (ts!p))" and
      q: "q < size ts" by auto    
    with less have "ts!q = Err" by auto
    moreover from q have "ts!q  Err" ..
    ultimately show False by blast
  qed
  
  show "(q,t)set(step p (map ok_val ts ! p)). t ⊑⇩r map ok_val ts ! q" 
  proof clarify
    fix q t assume q: "(q,t)  set (step p (map ok_val ts ! p))"

    from wt lp q
    obtain s where
      OKp:  "ts ! p = OK s" and
      less: "(q,t)  set (err_step (size ts) app step p (ts!p)). t <=_(Err.le r) ts!q"
      by (unfold wt_err_step_def wt_step_def stable_def) 
         (auto iff: not_Err_eq)

    from b lp app q have lq: "q < size ts" by (rule bounded_err_stepD)
    hence "ts!q  Err" ..
    then obtain s' where OKq: "ts ! q = OK s'" by (auto iff: not_Err_eq)

    from lp lq OKp OKq app less q
    show "t ⊑⇩r map ok_val ts ! q"
      by (auto simp add: err_step_def map_snd_def) 
  qed
qed
(*>*)


lemma wt_app_eff_imp_wt_err:
  assumes app_eff: "wt_app_eff r app step ts"
  assumes bounded: "bounded (err_step (size ts) app step) (size ts)"
  shows "wt_err_step r (err_step (size ts) app step) (map OK ts)"
(*<*)
proof (unfold wt_err_step_def wt_step_def, intro strip, rule conjI)
  fix p assume "p < size (map OK ts)" 
  hence p: "p < size ts" by simp
  thus "map OK ts ! p  Err" by simp
  { fix q t
    assume q: "(q,t)  set (err_step (size ts) app step p (map OK ts ! p))" 
    with p app_eff obtain 
      "app p (ts ! p)" "(q,t)  set (step p (ts!p)). t ⊑⇩r ts!q"
      by (unfold wt_app_eff_def) blast
    moreover
    from q p bounded have "q < size ts"
      by - (rule boundedD)
    hence "map OK ts ! q = OK (ts!q)" by simp
    moreover
    have "p < size ts" by (rule p)
    moreover note q
    ultimately     
    have "tErr.le r map OK ts ! q" 
      by (auto simp add: err_step_def map_snd_def)
  }
  thus "stable (Err.le r) (err_step (size ts) app step) (map OK ts) p"
    by (unfold stable_def) blast
qed
(*>*)

end

Theory Kildall

(*  Title:      JinjaThreads/DFA/Kildall.thy
    Author:     Tobias Nipkow, Gerwin Klein, Andreas Lochbihler
    Copyright   2000 TUM, 2010 KIT

Kildall's algorithm.
*)

section ‹Kildall's Algorithm \label{sec:Kildall}›

theory Kildall
imports SemilatAlg "../Basic/Auxiliary"
begin

locale Kildall_base =
  fixes s_α :: "'w  nat set"
  and s_empty :: "'w"
  and s_is_empty :: "'w  bool"
  and s_choose :: "'w  nat" 
  and s_remove :: "nat  'w  'w"
  and s_insert :: "nat  'w  'w"
begin

primrec propa :: "'s binop  (nat × 's) list  's list  'w  's list * 'w"
where
  "propa f []      τs w = (τs,w)"
| "propa f (q'#qs) τs w = (let (q,τ) = q';
                             u = τf τs!q;
                             w' = (if u = τs!q then w else s_insert q w)
                         in propa f qs (τs[q := u]) w')"

definition iter :: "'s binop  's step_type  's list  'w  's list × 'w"
where
  "iter f step τs w =
  while (λ(τs,w). ¬ s_is_empty w)
        (λ(τs,w). let p = s_choose w in propa f (step p (τs!p)) τs (s_remove p w))
        (τs,w)"

definition unstables :: "'s ord  's step_type  's list  'w"
where
  "unstables r step τs = foldr s_insert (filter (λp. ¬stable r step τs p) [0..<size τs]) s_empty"

definition kildall :: "'s ord  's binop  's step_type  's list  's list"
where "kildall r f step τs  fst(iter f step τs (unstables r step τs))"

primrec t_α :: "'s list × 'w  's list × nat set"
where "t_α (τs, w) = (τs, s_α w)"

end

primrec merges :: "'s binop  (nat × 's) list  's list  's list"
where
  "merges f []      τs = τs"
| "merges f (p'#ps) τs = (let (p,τ) = p' in merges f ps (τs[p := τf τs!p]))"


locale Kildall =
  Kildall_base +
  assumes empty_spec [simp]: "s_α s_empty = {}"
  and is_empty_spec [simp]: "s_is_empty A  s_α A = {}"
  and choose_spec: "s_α A  {}  s_choose A  s_α A"
  and remove_spec [simp]: "s_α (s_remove n A) = s_α A - {n}"
  and insert_spec [simp]: "s_α (s_insert n A) = insert n (s_α A)"
begin

lemma s_α_foldr_s_insert:
  "s_α (foldr s_insert xs A) = foldr insert xs (s_α A)"
by(induct xs arbitrary: A) simp_all

lemma unstables_spec [simp]: "s_α (unstables r step τs) = {p. p < size τs  ¬stable r step τs p}"
proof -
  have "{p. p < size τs  ¬stable r step τs p} = foldr insert (filter (λp. ¬stable r step τs p) [0..<size τs]) {}"
    unfolding foldr_insert_conv_set by auto
  thus ?thesis by(simp add: unstables_def s_α_foldr_s_insert)
qed

end

lemmas [simp] = Let_def Semilat.le_iff_plus_unchanged [OF Semilat.intro, symmetric]

lemma (in Semilat) nth_merges:
 "ss. p < length ss; ss  list n A; (p,t)set ps. p<n  tA  
  (merges f ps ss)!p = map snd [(p',t')  ps. p'=p]f ss!p"
  (is "ss. _; _; ?steptype ps  ?P ss ps")
(*<*)
proof (induct ps)
  show "ss. ?P ss []" by simp

  fix ss p' ps'
  assume ss: "ss  list n A"
  assume l:  "p < length ss"
  assume "?steptype (p'#ps')"
  then obtain a b where
    p': "p'=(a,b)" and ab: "a<n" "bA" and ps': "?steptype ps'"
    by (cases p') auto
  assume "ss. p< length ss  ss  list n A  ?steptype ps'  ?P ss ps'"
  hence IH: "ss. ss  list n A  p < length ss  ?P ss ps'" using ps' by iprover

  from ss ab
  have "ss[a := bf ss!a]  list n A" by (simp add: closedD)
  moreover
  with l have "p < length (ss[a := bf ss!a])" by simp
  ultimately
  have "?P (ss[a := bf ss!a]) ps'" by (rule IH)
  with p' l
  show "?P ss (p'#ps')" by simp
qed
(*>*)


(** merges **)

lemma length_merges [simp]:
  "ss. size(merges f ps ss) = size ss"
(*<*) by (induct ps, auto) (*>*)

lemma (in Semilat) merges_preserves_type_lemma:
shows "xs. xs  list n A  ((p,x)  set ps. p<n  xA)
          merges f ps xs  list n A"
(*<*)
apply (insert closedI)
apply (unfold Semilat.closed_def)
apply (induct ps)
 apply simp
apply clarsimp
done
(*>*)

lemma (in Semilat) merges_preserves_type [simp]:
 " xs  list n A; (p,x)  set ps. p<n  xA 
   merges f ps xs  list n A"
by (simp add: merges_preserves_type_lemma)

lemma (in Semilat) merges_incr_lemma:
 "xs. xs  list n A  ((p,x)set ps. p<size xs  x  A)  xs [⊑r] merges f ps xs"
(*<*)
apply (induct ps)
 apply simp
apply simp
apply clarify
apply (rule order_trans)
  apply simp
 apply (erule list_update_incr)
  apply simp
 apply simp
apply (blast intro!: listE_set intro: closedD listE_length [THEN nth_in])
done
(*>*)

lemma (in Semilat) merges_incr:
 " xs  list n A; (p,x)set ps. p<size xs  x  A  
   xs [⊑r] merges f ps xs"
  by (simp add: merges_incr_lemma)


lemma (in Semilat) merges_same_conv [rule_format]:
 "(xs. xs  list n A  ((p,x)set ps. p<size xs  xA)  
     (merges f ps xs = xs) = ((p,x)set ps. xr xs!p))"
(*<*)
  apply (induct_tac ps)
   apply simp
  apply clarsimp
  apply (rename_tac p x ps xs)
  apply (rule iffI)
   apply (rule context_conjI)
    apply (subgoal_tac "xs[p := xf xs!p] [⊑r] xs")
     apply (force dest!: le_listD simp add: nth_list_update)
    apply (erule subst, rule merges_incr)
       apply (blast intro!: listE_set intro: closedD listE_length [THEN nth_in])
      apply clarify
      apply (rule conjI)
       apply simp
       apply (blast dest: boundedD)
      apply blast
   apply clarify
   apply (erule allE)
   apply (erule impE)
    apply assumption
   apply (drule bspec)
    apply assumption
   apply (simp add: le_iff_plus_unchanged [THEN iffD1] list_update_same_conv [THEN iffD2])
   apply blast
  apply clarify 
  apply (simp add: le_iff_plus_unchanged [THEN iffD1] list_update_same_conv [THEN iffD2])
  done
(*>*)


lemma (in Semilat) list_update_le_listI [rule_format]:
  "set xs  A  set ys  A  xs [⊑r] ys  p < size xs   
   xr ys!p  xA  xs[p := xf xs!p] [⊑r] ys"
(*<*)
  apply(insert semilat)
  apply (simp only: Listn.le_def lesub_def semilat_def)
  apply (simp add: list_all2_conv_all_nth nth_list_update)
  done
(*>*)

lemma (in Semilat) merges_pres_le_ub:
  assumes "set ts  A"  "set ss  A"
    "(p,t)set ps. tr ts!p  t  A  p < size ts"  "ss [⊑r] ts"
  shows "merges f ps ss [⊑r] ts"
(*<*)
proof -
  { fix t ts ps
    have
    "qs. set ts  A; (p,t)set ps. tr ts!p  t  A  p< size ts  
    set qs  set ps   
    (ss. set ss  A  ss [⊑r] ts  merges f qs ss [⊑r] ts)"
    apply (induct_tac qs)
     apply simp
    apply (simp (no_asm_simp))
    apply clarify
    apply simp
    apply (erule allE, erule impE, erule_tac [2] mp)
     apply (drule bspec, assumption)
     apply (simp add: closedD)
    apply (drule bspec, assumption)
    apply (simp add: list_update_le_listI)
    done 
  } note this [dest]  
  from assms show ?thesis by blast
qed
(*>*)

context Kildall begin

subsection @{term propa}

lemma decomp_propa:
  "ss w. ((q,t)set qs. q < size ss)  
   t_α (propa f qs ss w) = 
   (merges f qs ss, {q. t.(q,t)set qs  tf ss!q  ss!q}  s_α w)"
  apply (induct qs)
   apply simp   
  apply (simp (no_asm))
  apply clarify  
  apply simp
  apply (rule conjI) 
   apply blast
  apply (simp add: nth_list_update)
  apply blast
  done 

end

lemma (in Semilat) stable_pres_lemma:
shows "pres_type step n A; bounded step n; 
     ss  list n A; p  w; qw. q < n; 
     q. q < n  q  w  stable r step ss q; q < n; 
     s'. (q,s')  set (step p (ss!p))  s'f ss!q = ss!q; 
     q  w  q = p  
   stable r step (merges f (step p (ss!p)) ss) q"
(*<*)
  apply (unfold stable_def)
  apply (subgoal_tac "s'. (q,s')  set (step p (ss!p))  s' : A")
   prefer 2
   apply clarify
   apply (erule pres_typeD)
    prefer 3 apply assumption
    apply (rule listE_nth_in)
     apply assumption
    apply simp
   apply simp
  apply simp
  apply clarify
  apply (subst nth_merges)
       apply simp
       apply (blast dest: boundedD)
      apply assumption
     apply clarify
     apply (rule conjI)
      apply (blast dest: boundedD)
     apply (erule pres_typeD)
       prefer 3 apply assumption
      apply simp
     apply simp
apply(subgoal_tac "q < length ss")
prefer 2 apply simp
  apply (frule nth_merges [of q _ _ "step p (ss!p)"]) (* fixme: why does method subst not work?? *)
apply assumption
  apply clarify
  apply (rule conjI)
   apply (blast dest: boundedD)
  apply (erule pres_typeD)
     prefer 3 apply assumption
    apply simp
   apply simp
  apply (drule_tac P = "λx. (a, b)  set (step q x)" in subst)
   apply assumption

 apply (simp add: plusplus_empty)
 apply (cases "q  w")
  apply simp
  apply (rule ub1')
     apply (rule Semilat.intro)
     apply (rule semilat)
    apply clarify
    apply (rule pres_typeD)
       apply assumption
      prefer 3 apply assumption
     apply (blast intro: listE_nth_in dest: boundedD)
    apply (blast intro: pres_typeD dest: boundedD)
   apply (blast intro: listE_nth_in dest: boundedD)
  apply assumption

 apply simp
 apply (erule allE, erule impE, assumption, erule impE, assumption)
 apply (rule order_trans)
   apply simp
  defer
 apply (rule pp_ub2)(*
    apply assumption*)
   apply simp
   apply clarify
   apply simp
   apply (rule pres_typeD)
      apply assumption
     prefer 3 apply assumption
    apply (blast intro: listE_nth_in dest: boundedD)
   apply (blast intro: pres_typeD dest: boundedD)
  apply (blast intro: listE_nth_in dest: boundedD)
 apply blast
 done
(*>*)


lemma (in Semilat) merges_bounded_lemma:
 " mono r step n A; bounded step n; 
    (p',s')  set (step p (ss!p)). s'  A; ss  list n A; ts  list n A; p < n; 
    ss [⊑⇩r] ts; p. p < n  stable r step ts p  
   merges f (step p (ss!p)) ss [⊑⇩r] ts" 
(*<*)
  apply (unfold stable_def)
  apply (rule merges_pres_le_ub)
     apply simp
    apply simp
   prefer 2 apply assumption

  apply clarsimp
  apply (drule boundedD, assumption+)
  apply (erule allE, erule impE, assumption)
  apply (drule bspec, assumption)
  apply simp

  apply (drule monoD [of _ _ _ _ p "ss!p"  "ts!p"])
     apply assumption
    apply simp
   apply (simp add: le_listD)
  
  apply (drule lesub_step_typeD, assumption) 
  apply clarify
  apply (drule bspec, assumption)
  apply simp
  apply (blast intro: order_trans)
  done
(*>*)


lemma termination_lemma: assumes "Semilat A r f"
shows " ss  list n A; (q,t)set qs. q<n  tA; pw   
      ss [⊏⇩r] merges f qs ss  
  merges f qs ss = ss  {q. t. (q,t)set qs  tf ss!q  ss!q}  (w-{p})  w"
(*<*) (is "PROP ?P")
proof -
  interpret Semilat A r f by fact
  show "PROP ?P"
  apply(insert semilat)
    apply (unfold lesssub_def)
    apply (simp (no_asm_simp) add: merges_incr)
    apply (rule impI)
    apply (rule merges_same_conv [THEN iffD1, elim_format]) 
    apply assumption+
      defer
      apply (rule sym, assumption)
     defer apply simp
     apply (subgoal_tac "q t. ¬((q, t)  set qs  tf ss ! q  ss ! q)")
     apply (blast intro!: psubsetI elim: equalityE)
     apply clarsimp
     apply (drule bspec, assumption) 
     apply (drule bspec, assumption)
     apply clarsimp
    done 
qed
(*>*)

context Kildall_base begin

definition s_finite_psubset  :: "('w * 'w) set"
where "s_finite_psubset == {(A,B). s_α A < s_α B & finite (s_α B)}"

lemma s_finite_psubset_inv_image:
  "s_finite_psubset = inv_image finite_psubset s_α"
by(auto simp add: s_finite_psubset_def finite_psubset_def)

lemma wf_s_finite_psubset [simp]: "wf s_finite_psubset"
unfolding s_finite_psubset_inv_image by simp

end

context Kildall begin

subsection @{term iter}

lemma iter_properties[rule_format]: assumes "Semilat A r f"
shows " acc A r; pres_type step n A; mono r step n A;
     bounded step n; ps_α w0. p < n; ss0  list n A;
     p<n. p  s_α w0  stable r step ss0 p  
   t_α (iter f step ss0 w0) = (ss',w')
   
   ss'  list n A  stables r step ss'  ss0 [⊑⇩r] ss' 
   (tslist n A. ss0 [⊑⇩r] ts  stables r step ts  ss' [⊑⇩r] ts)"
(*<*) (is "PROP ?P")
proof -
  interpret Semilat A r f by fact
  show "PROP ?P"
  apply(insert semilat)
  apply (unfold iter_def stables_def)
  apply(unfold is_empty_spec)
  apply (rule_tac P = "λ(ss,w).
   ss  list n A  (p<n. p  s_α w  stable r step ss p)  ss0 [⊑⇩r] ss 
   (tslist n A. ss0 [⊑⇩r] ts  stables r step ts  ss [⊑⇩r] ts) 
   (p s_α w. p < n)" and
   r = "{(ss',ss) . ss  list n A  ss'  list n A  ss [⊏⇩r] ss'} <*lex*> s_finite_psubset"
         in while_rule)

  ― ‹Invariant holds initially:›
  apply (simp add:stables_def)

  ― ‹Invariant is preserved:›
  apply(simp add: stables_def split_paired_all)
  apply(rename_tac ss w)
  apply(subgoal_tac "s_choose w  s_α w")
   prefer 2 apply(erule choose_spec)
  apply(subgoal_tac "(q,t)  set (step (s_choose w) (ss ! (s_choose w))). q < length ss  t  A")
   prefer 2
   apply clarify
   apply (rule conjI)
    apply(clarsimp, blast dest!: boundedD)
   apply (erule pres_typeD)
    prefer 3
    apply assumption
    apply (erule listE_nth_in)
    apply blast
   apply blast
  apply(subgoal_tac "(λ(ss, w).
              ss  list n A 
              (p<n. p  w  stable r step ss p) 
              ss0 [⊑r] ss 
              (tslist n A.
                  ss0 [⊑r] ts  (p<n. stable r step ts p)  ss [⊑r] ts) 
              (pw. p < n))
           (t_α (propa f (step (s_choose w) (ss ! s_choose w)) ss
             (s_remove (s_choose w) w)))")
   apply(case_tac "propa f (step (s_choose w) (ss ! s_choose w)) ss (s_remove (s_choose w) w)")
   apply(simp)  
  apply (subst decomp_propa)
   apply blast
  apply simp
  apply (rule conjI)
   apply (rule merges_preserves_type)
   apply blast
   apply clarify
   apply (rule conjI)
    apply(clarsimp, blast dest!: boundedD)
   apply (erule pres_typeD)
    prefer 3
    apply assumption
    apply (erule listE_nth_in)
    apply blast
   apply blast
  apply (rule conjI)
   apply clarify
   apply (blast intro!: stable_pres_lemma)
  apply (rule conjI)
   apply (blast intro!: merges_incr intro: le_list_trans)
  apply (rule conjI)
   apply clarsimp
   apply (blast intro!: merges_bounded_lemma)
  apply (blast dest!: boundedD)


  ― ‹Postcondition holds upon termination:›
  apply(clarsimp simp add: stables_def split_paired_all)

  ― ‹Well-foundedness of the termination relation:›
  apply (rule wf_lex_prod)
   apply (insert orderI [THEN acc_le_listI])
   apply (simp only: acc_def lesssub_def)
  apply (rule wf_s_finite_psubset) 

  ― ‹Loop decreases along termination relation:›
  apply(simp add: stables_def split_paired_all)
  apply(rename_tac ss w)
  apply(subgoal_tac "s_choose w  s_α w")
   prefer 2 apply (erule choose_spec)
  apply(subgoal_tac "(q,t)  set (step (s_choose w) (ss ! (s_choose w))). q < length ss  t  A")
   prefer 2
   apply clarify
   apply (rule conjI)
    apply(clarsimp, blast dest!: boundedD)
   apply (erule pres_typeD)
    prefer 3
    apply assumption
    apply (erule listE_nth_in)
    apply blast
   apply blast
  apply(subgoal_tac "(t_α (propa f (step (s_choose w) (ss ! s_choose w)) ss
            (s_remove (s_choose w) w)),
           ss, s_α w)
           {(ss', ss). ss  list n A  ss'  list n A  ss [⊏r] ss'} <*lex*> finite_psubset")
   prefer 2
   apply (subst decomp_propa)
    apply blast
   apply clarify
   apply (simp del: listE_length
               add: lex_prod_def finite_psubset_def bounded_nat_set_is_finite)
   apply(subgoal_tac "merges f (step (s_choose w) (ss ! s_choose w)) ss  list n A")
    apply simp
    apply (rule termination_lemma)
    apply (rule assms)
    apply assumption+
   apply clarsimp
  apply(case_tac "propa f (step (s_choose w) (ss ! s_choose w)) ss
               (s_remove (s_choose w) w)")
  apply(simp add: s_finite_psubset_inv_image)
  done
qed
(*>*)

lemma kildall_properties: assumes "Semilat A r f"
shows " acc A r; pres_type step n A; mono r step n A;
     bounded step n; ss0  list n A  
  kildall r f step ss0  list n A 
  stables r step (kildall r f step ss0) 
  ss0 [⊑⇩r] kildall r f step ss0 
  (tslist n A. ss0 [⊑⇩r] ts  stables r step ts 
                 kildall r f step ss0 [⊑⇩r] ts)"
(*<*) (is "PROP ?P")
proof -
  interpret Semilat A r f by fact
  show "PROP ?P"
  apply (unfold kildall_def)
  apply(case_tac "iter f step ss0 (unstables r step ss0)")
  apply(simp)
  apply (rule iter_properties[where ?w0.0="unstables r step ss0"])
  apply(rule assms)
  apply (simp_all add: unstables_def stable_def s_α_foldr_s_insert foldr_insert_conv_set)
  done
qed

lemma is_bcv_kildall: assumes "Semilat A r f"
shows " acc A r; top r T; pres_type step n A; bounded step n; mono r step n A 
   is_bcv r T step n A (kildall r f step)" (is "PROP ?P")
proof -
  interpret Semilat A r f by fact
  show "PROP ?P"
  apply(unfold is_bcv_def wt_step_def)
  apply(insert ‹Semilat A r f semilat kildall_properties[of A])
  apply(simp add:stables_def)
  apply clarify
  apply(subgoal_tac "kildall r f step τs0  list n A")
   prefer 2 apply (simp(no_asm_simp))
  apply (rule iffI)
   apply (rule_tac x = "kildall r f step τs0" in bexI) 
    apply (rule conjI)
     apply (blast)
    apply (simp  (no_asm_simp))
   apply(assumption)
  apply clarify
  apply(subgoal_tac "kildall r f step τs0!p <=_r τs!p")
   apply simp
  apply (blast intro!: le_listD less_lengthI)
  done
qed
(*>*)

end

interpretation Kildall "set" "[]" "λxs. xs = []" "hd" "removeAll" "Cons"
by(unfold_locales) auto

lemmas kildall_code [code] = 
  kildall_def
  Kildall_base.propa.simps 
  Kildall_base.iter_def 
  Kildall_base.unstables_def
  Kildall_base.kildall_def

end

Theory LBVSpec

(*  Title:      HOL/MicroJava/BV/LBVSpec.thy
    Author:     Gerwin Klein
    Copyright   1999 Technische Universitaet Muenchen
*)

section ‹The Lightweight Bytecode Verifier›

theory LBVSpec
imports SemilatAlg Opt
begin

type_synonym
  's certificate = "'s list"   

primrec merge :: "'s certificate  's binop  's ord  's  nat  (nat × 's) list  's  's"
where
  "merge cert f r T pc []     x = x"
| "merge cert f r T pc (s#ss) x = merge cert f r T pc ss (let (pc',s') = s in 
                                  if pc'=pc+1 then s' ⊔⇩f x
                                  else if s' ⊑⇩r cert!pc' then x
                                  else T)"

definition wtl_inst :: "'s certificate  's binop  's ord  's 
              's step_type  nat  's  's"
where
  "wtl_inst cert f r T step pc s = merge cert f r T pc (step pc s) (cert!(pc+1))"

definition wtl_cert :: "'s certificate  's binop  's ord  's  's 
              's step_type  nat  's  's"
where
  "wtl_cert cert f r T B step pc s =
  (if cert!pc = B then 
    wtl_inst cert f r T step pc s
  else
    if s ⊑⇩r cert!pc then wtl_inst cert f r T step pc (cert!pc) else T)"

primrec wtl_inst_list :: "'a list  's certificate  's binop  's ord  's  's 
                    's step_type  nat  's  's"
where
  "wtl_inst_list []     cert f r T B step pc s = s"
| "wtl_inst_list (i#is) cert f r T B step pc s = 
    (let s' = wtl_cert cert f r T B step pc s in
      if s' = T  s = T then T else wtl_inst_list is cert f r T B step (pc+1) s')"

definition cert_ok :: "'s certificate  nat  's  's  's set  bool"
where
  "cert_ok cert n T B A  (i < n. cert!i  A  cert!i  T)  (cert!n = B)"

definition bottom :: "'a ord  'a  bool"
where
  "bottom r B  (x. B ⊑⇩r x)"


locale lbv = Semilat +
  fixes T :: "'a" ("") 
  fixes B :: "'a" ("") 
  fixes step :: "'a step_type" 
  assumes top: "top r "
  assumes T_A: "  A"
  assumes bot: "bottom r " 
  assumes B_A: "  A"

  fixes merge :: "'a certificate  nat  (nat × 'a) list  'a  'a"
  defines mrg_def: "merge cert  LBVSpec.merge cert f r "

  fixes wti :: "'a certificate  nat  'a  'a"
  defines wti_def: "wti cert  wtl_inst cert f r  step"
 
  fixes wtc :: "'a certificate  nat  'a  'a"
  defines wtc_def: "wtc cert  wtl_cert cert f r   step"

  fixes wtl :: "'b list  'a certificate  nat  'a  'a"
  defines wtl_def: "wtl ins cert  wtl_inst_list ins cert f r   step"


lemma (in lbv) wti:
  "wti c pc s = merge c pc (step pc s) (c!(pc+1))"
  (*<*) by (simp add: wti_def mrg_def wtl_inst_def) (*>*)

lemma (in lbv) wtc: 
  "wtc c pc s = (if c!pc =  then wti c pc s else if s ⊑⇩r c!pc then wti c pc (c!pc) else )"
  (*<*) by (unfold wtc_def wti_def wtl_cert_def) rule (*>*)

lemma cert_okD1 [intro?]:
  "cert_ok c n T B A  pc < n  c!pc  A"
  (*<*) by (unfold cert_ok_def) fast (*>*)

lemma cert_okD2 [intro?]:
  "cert_ok c n T B A  c!n = B"
  (*<*) by (simp add: cert_ok_def) (*>*)

lemma cert_okD3 [intro?]:
  "cert_ok c n T B A  B  A  pc < n  c!Suc pc  A"
  (*<*) by (drule Suc_leI) (auto simp add: le_eq_less_or_eq dest: cert_okD1 cert_okD2) (*>*)

lemma cert_okD4 [intro?]:
  "cert_ok c n T B A  pc < n  c!pc  T"
  (*<*) by (simp add: cert_ok_def) (*>*)

declare Let_def [simp]

subsection "more semilattice lemmas"


lemma (in lbv) sup_top [simp, elim]:
  assumes x: "x  A" 
  shows "x ⊔⇩f  = "
(*<*)
proof -
  from top have "x ⊔⇩f  ⊑⇩r " ..
  moreover from x T_A have " ⊑⇩r x ⊔⇩f " ..
  ultimately show ?thesis ..
qed
(*>*)
  
lemma (in lbv) plusplussup_top [simp, elim]:
  "set xs  A  xsf  = "
  by (induct xs) auto


lemma (in Semilat) pp_ub1':
  assumes S: "snd`set S  A" 
  assumes y: "y  A" and ab: "(a, b)  set S" 
  shows "b ⊑⇩r map snd [(p', t')  S . p' = a]f y"
(*<*)
proof -
  from S have "(x,y)  set S. y  A" by auto
  with Semilat_axioms show ?thesis using y ab by (rule ub1')
qed 
(*>*)

lemma (in lbv) bottom_le [simp, intro!]: " ⊑⇩r x"
  by (insert bot) (simp add: bottom_def)

lemma (in lbv) le_bottom [simp]: "x ⊑⇩r  = (x = )"
  by (blast intro: antisym_r)


subsection "merge"

lemma (in lbv) merge_Nil [simp]:
  "merge c pc [] x = x" by (simp add: mrg_def)

lemma (in lbv) merge_Cons [simp]:
  "merge c pc (l#ls) x = merge c pc ls (if fst l=pc+1 then snd l +_f x
                                        else if snd l ⊑⇩r c!fst l then x
                                        else )"
  by (simp add: mrg_def split_beta)

lemma (in lbv) merge_Err [simp]:
  "snd`set ss  A  merge c pc ss  = "
  by (induct ss) auto

lemma (in lbv) merge_not_top:
  "x. snd`set ss  A  merge c pc ss x    
  (pc',s')  set ss. (pc'  pc+1  s' ⊑⇩r c!pc')"
  (is "x. ?set ss  ?merge ss x  ?P ss")
(*<*)
proof (induct ss)
  show "?P []" by simp
next
  fix x ls l
  assume "?set (l#ls)" then obtain set: "snd`set ls  A" by simp
  assume merge: "?merge (l#ls) x" 
  moreover
  obtain pc' s' where [simp]: "l = (pc',s')" by (cases l)
  ultimately
  obtain x' where merge': "?merge ls x'" by simp 
  assume "x. ?set ls  ?merge ls x  ?P ls" hence "?P ls" using set merge' .
  moreover
  from merge set
  have "pc'  pc+1  s' ⊑⇩r c!pc'" by (simp split: if_split_asm)
  ultimately show "?P (l#ls)" by simp
qed
(*>*)


lemma (in lbv) merge_def:
  shows 
  "x. x  A  snd`set ss  A 
  merge c pc ss x = 
  (if (pc',s')  set ss. pc'pc+1  s' ⊑⇩r c!pc' then
    map snd [(p',t')  ss. p'=pc+1]f x
  else )" 
  (is "x. _  _  ?merge ss x = ?if ss x" is "x. _  _  ?P ss x")
(*<*)
proof (induct ss)
  fix x show "?P [] x" by simp
next 
  fix x assume x: "x  A" 
  fix l::"nat × 'a" and ls  
  assume "snd`set (l#ls)  A"
  then obtain l: "snd l  A" and ls: "snd`set ls  A" by auto
  assume "x. x  A  snd`set ls  A  ?P ls x" 
  hence IH: "x. x  A  ?P ls x" using ls by iprover
  obtain pc' s' where [simp]: "l = (pc',s')" by (cases l)
  hence "?merge (l#ls) x = ?merge ls 
    (if pc'=pc+1 then s' ⊔⇩f x else if s' ⊑⇩r c!pc' then x else )"
    (is "?merge (l#ls) x = ?merge ls ?if'")
    by simp 
  also have " = ?if ls ?if'" 
  proof -
    from l have "s'  A" by simp
    with x have "s' ⊔⇩f x  A" by simp
    with x T_A have "?if'  A" by auto
    hence "?P ls ?if'" by (rule IH) thus ?thesis by simp
  qed
  also have " = ?if (l#ls) x"
    proof (cases "(pc', s')set (l#ls). pc'pc+1  s' ⊑⇩r c!pc'")
      case True
      hence "(pc', s')set ls. pc'pc+1  s' ⊑⇩r c!pc'" by auto
      moreover
      from True have 
        "map snd [(p',t')  ls . p'=pc+1]f ?if' = 
        (map snd [(p',t')  l#ls . p'=pc+1]f x)"
        by simp
      ultimately
      show ?thesis using True by simp
    next
      case False 
      moreover
      from ls have "set (map snd [(p', t')  ls . p' = Suc pc])  A" by auto
      ultimately show ?thesis by auto
    qed
  finally show "?P (l#ls) x" .
qed
(*>*)

lemma (in lbv) merge_not_top_s:
  assumes x:  "x  A" and ss: "snd`set ss  A"
  assumes m:  "merge c pc ss x  "
  shows "merge c pc ss x = (map snd [(p',t')  ss. p'=pc+1]f x)"
(*<*)
proof -
  from ss m have "(pc',s')  set ss. (pc'  pc+1  s' <=_r c!pc')" 
    by (rule merge_not_top)
  with x ss m show ?thesis by - (drule merge_def, auto split: if_split_asm)
qed
(*>*)

subsection "wtl-inst-list"

lemmas [iff] = not_Err_eq

lemma (in lbv) wtl_Nil [simp]: "wtl [] c pc s = s" 
  by (simp add: wtl_def)

lemma (in lbv) wtl_Cons [simp]: 
  "wtl (i#is) c pc s = 
  (let s' = wtc c pc s in if s' =   s =  then  else wtl is c (pc+1) s')"
  by (simp add: wtl_def wtc_def)

lemma (in lbv) wtl_Cons_not_top:
  "wtl (i#is) c pc s   = 
  (wtc c pc s    s  T  wtl is c (pc+1) (wtc c pc s)  )"
  by (auto simp del: split_paired_Ex)

lemma (in lbv) wtl_top [simp]:  "wtl ls c pc  = "
  by (cases ls) auto

lemma (in lbv) wtl_not_top:
  "wtl ls c pc s    s  "
  by (cases "s=") auto

lemma (in lbv) wtl_append [simp]:
  "pc s. wtl (a@b) c pc s = wtl b c (pc+length a) (wtl a c pc s)"
  by (induct a) auto

lemma (in lbv) wtl_take:
  "wtl is c pc s    wtl (take pc' is) c pc s  "
  (is "?wtl is  _  _")
(*<*)
proof -
  assume "?wtl is  "
  hence "?wtl (take pc' is @ drop pc' is)  " by simp  
  thus ?thesis by (auto dest!: wtl_not_top simp del: append_take_drop_id)
qed
(*>*)

lemma take_Suc:
  "n. n < length l  take (Suc n) l = (take n l)@[l!n]" (is "?P l")
(*<*)
proof (induct l)
  show "?P []" by simp
next
  fix x xs assume IH: "?P xs"  
  show "?P (x#xs)"
  proof (intro strip)
    fix n assume "n < length (x#xs)"
    with IH show "take (Suc n) (x # xs) = take n (x # xs) @ [(x # xs) ! n]" 
      by (cases n, auto)
  qed
qed
(*>*)

lemma (in lbv) wtl_Suc:
  assumes suc: "pc+1 < length is"
  assumes wtl: "wtl (take pc is) c 0 s  "
  shows "wtl (take (pc+1) is) c 0 s = wtc c pc (wtl (take pc is) c 0 s)"
(*<*)
proof -
  from suc have "take (pc+1) is=(take pc is)@[is!pc]" by (simp add: take_Suc)
  with suc wtl show ?thesis by (simp add: min_def)
qed
(*>*)

lemma (in lbv) wtl_all:
  assumes all: "wtl is c 0 s  " (is "?wtl is  _") 
  assumes pc:  "pc < length is"
  shows  "wtc c pc (wtl (take pc is) c 0 s)  "
(*<*)
proof -
  from pc have "0 < length (drop pc is)" by simp
  then  obtain i r where Cons: "drop pc is = i#r" 
    by (auto simp add: neq_Nil_conv simp del: length_drop drop_eq_Nil)
  hence "i#r = drop pc is" ..
  with all have take: "?wtl (take pc is@i#r)  " by simp 
  from pc have "is!pc = drop pc is ! 0" by simp
  with Cons have "is!pc = i" by simp
  with take pc show ?thesis by (auto simp add: min_def split: if_split_asm)
qed
(*>*)

subsection "preserves-type"

lemma (in lbv) merge_pres:
  assumes s0: "snd`set ss  A" and x: "x  A"
  shows "merge c pc ss x  A"
(*<*)
proof -
  from s0 have "set (map snd [(p', t')  ss . p'=pc+1])  A" by auto
  with x semilat Semilat_axioms  have "(map snd [(p', t')  ss . p'=pc+1]f x)  A"
    by (auto intro!: plusplus_closed)
  with s0 x show ?thesis by (simp add: merge_def T_A)
qed
(*>*)
  
lemma pres_typeD2:
  "pres_type step n A  s  A  p < n  snd`set (step p s)  A"
  by auto (drule pres_typeD)

lemma (in lbv) wti_pres [intro?]:
  assumes pres: "pres_type step n A" 
  assumes cert: "c!(pc+1)  A"
  assumes s_pc: "s  A" "pc < n"
  shows "wti c pc s  A"
(*<*)
proof -
  from pres s_pc have "snd`set (step pc s)  A" by (rule pres_typeD2)
  with cert show ?thesis by (simp add: wti merge_pres)
qed
(*>*)

lemma (in lbv) wtc_pres:
  assumes "pres_type step n A"
  assumes "c!pc  A" and "c!(pc+1)  A"
  assumes "s  A" and "pc < n"
  shows "wtc c pc s  A"
(*<*)
proof -
  have "wti c pc s  A" using assms(1,3-5) ..
  moreover have "wti c pc (c!pc)  A" using assms(1,3,2,5) ..
  ultimately show ?thesis using T_A by (simp add: wtc) 
qed
(*>*)

lemma (in lbv) wtl_pres:
  assumes pres: "pres_type step (length is) A"
  assumes cert: "cert_ok c (length is)   A"
  assumes s:    "s  A" 
  assumes all:  "wtl is c 0 s  "
  shows "pc < length is  wtl (take pc is) c 0 s  A"
  (is "?len pc  ?wtl pc  A")
(*<*)
proof (induct pc)
  from s show "?wtl 0  A" by simp
next
  fix n assume Suc_n: "Suc n < length is"
  hence n1: "n+1 < length is" by simp
  then obtain n: "n < length is" by simp
  assume "n < length is  ?wtl n  A"
  hence "?wtl n  A" using n .
  from pres _ _ this n
  have "wtc c n (?wtl n)  A"
  proof (rule wtc_pres)
    from cert n show "c!n  A" by (rule cert_okD1)
    from cert n1 show "c!(n+1)  A" by (rule cert_okD1)
  qed
  also
  from all n have "?wtl n  " by - (rule wtl_take)
  with n1 have "wtc c n (?wtl n) = ?wtl (n+1)" by (rule wtl_Suc [symmetric])
  finally  show "?wtl (Suc n)  A" by simp
qed
(*>*)

end

Theory LBVCorrect

(*
    Author:     Gerwin Klein
    Copyright   1999 Technische Universitaet Muenchen
*)

section ‹Correctness of the LBV›

theory LBVCorrect
imports LBVSpec Typing_Framework
begin

locale lbvs = lbv +
  fixes s0  :: 'a
  fixes c   :: "'a list"
  fixes ins :: "'b list"
  fixes τs  :: "'a list"
  defines phi_def:
  "τs  map (λpc. if c!pc =  then wtl (take pc ins) c 0 s0 else c!pc) 
       [0..<size ins]"

  assumes bounded: "bounded step (size ins)"
  assumes cert: "cert_ok c (size ins)   A"
  assumes pres: "pres_type step (size ins) A"

lemma (in lbvs) phi_None [intro?]:
  " pc < size ins; c!pc =    τs!pc = wtl (take pc ins) c 0 s0"
(*<*) by (simp add: phi_def) (*>*)

lemma (in lbvs) phi_Some [intro?]:
  " pc < size ins; c!pc     τs!pc = c!pc"
(*<*) by (simp add: phi_def) (*>*)

lemma (in lbvs) phi_len [simp]: "size τs = size ins"
(*<*) by (simp add: phi_def) (*>*)

lemma (in lbvs) wtl_suc_pc:
  assumes all: "wtl ins c 0 s0  " 
  assumes pc:  "pc+1 < size ins"
  shows "wtl (take (pc+1) ins) c 0 s0 ⊑⇩r τs!(pc+1)"
(*<*)
proof -
  from all pc
  have "wtc c (pc+1) (wtl (take (pc+1) ins) c 0 s0)  T" by (rule wtl_all)
  with pc show ?thesis by (simp add: phi_def wtc split: if_split_asm)
qed
(*>*)

lemma (in lbvs) wtl_stable:
  assumes wtl: "wtl ins c 0 s0  " 
  assumes s0:  "s0  A" and  pc:  "pc < size ins" 
  shows "stable r step τs pc"
(*<*)
proof (unfold stable_def, clarify)
  fix pc' s' assume step: "(pc',s')  set (step pc (τs ! pc))" 
                      (is "(pc',s')  set (?step pc)")
  
  from bounded pc step have pc': "pc' < size ins" by (rule boundedD)

  have tkpc: "wtl (take pc ins) c 0 s0  " (is "?s1  _") using wtl by (rule wtl_take)
  have s2: "wtl (take (pc+1) ins) c 0 s0  " (is "?s2  _") using wtl by (rule wtl_take)
  
  from wtl pc have wt_s1: "wtc c pc ?s1  " by (rule wtl_all)

  have c_Some: "pc t. pc < size ins  c!pc    τs!pc = c!pc" 
    by (simp add: phi_def)
  have c_None: "c!pc =   τs!pc = ?s1" using pc ..

  from wt_s1 pc c_None c_Some
  have inst: "wtc c pc ?s1  = wti c pc (τs!pc)"
    by (simp add: wtc split: if_split_asm)

  have "?s1  A" using pres cert s0 wtl pc by (rule wtl_pres)
  with pc c_Some cert c_None
  have "τs!pc  A" by (cases "c!pc = ") (auto dest: cert_okD1)
  with pc pres
  have step_in_A: "snd`set (?step pc)  A" by (auto dest: pres_typeD2)

  show "s' ⊑⇩r τs!pc'" 
  proof (cases "pc' = pc+1")
    case True
    with pc' cert
    have cert_in_A: "c!(pc+1)  A" by (auto dest: cert_okD1)
    from True pc' have pc1: "pc+1 < size ins" by simp
    with tkpc have "?s2 = wtc c pc ?s1" by - (rule wtl_Suc)
    with inst 
    have merge: "?s2 = merge c pc (?step pc) (c!(pc+1))" by (simp add: wti)
    also from s2 merge have "  " (is "?merge  _") by simp
    with cert_in_A step_in_A
    have "?merge = (map snd [(p',t')  ?step pc. p'=pc+1]f c!(pc+1))"
      by (rule merge_not_top_s) 
    finally have "s' ⊑⇩r ?s2" using step_in_A cert_in_A True step 
      by (auto intro: pp_ub1')
    also from wtl pc1 have "?s2 ⊑⇩r τs!(pc+1)" by (rule wtl_suc_pc)
    also note True [symmetric]
    finally show ?thesis by simp    
  next
    case False
    from wt_s1 inst 
    have "merge c pc (?step pc) (c!(pc+1))  " by (simp add: wti)
    with step_in_A have "(pc', s')set (?step pc). pc'pc+1  s' ⊑⇩r c!pc'"
      by - (rule merge_not_top)
    with step False  have ok: "s' ⊑⇩r c!pc'" by blast
    moreover from ok have "c!pc' =   s' = " by simp
    moreover from c_Some pc'  have "c!pc'    τs!pc' = c!pc'" by auto
    ultimately show ?thesis by (cases "c!pc' = ") auto 
  qed
qed
(*>*)
  
lemma (in lbvs) phi_not_top:
  assumes wtl: "wtl ins c 0 s0  " and pc:  "pc < size ins"
  shows "τs!pc  "
(*<*)
proof (cases "c!pc = ")
  case False with pc
  have "τs!pc = c!pc" ..
  also from cert pc have "  " by (rule cert_okD4)
  finally show ?thesis .
next
  case True with pc
  have "τs!pc = wtl (take pc ins) c 0 s0" ..
  also from wtl have "  " by (rule wtl_take)
  finally show ?thesis .
qed
(*>*)

lemma (in lbvs) phi_in_A:
  assumes wtl: "wtl ins c 0 s0  " and s0: "s0  A"
  shows "τs  list (size ins) A"
(*<*)
proof -
  { fix x assume "x  set τs"
    then obtain xs ys where "τs = xs @ x # ys" 
      by (auto simp add: in_set_conv_decomp)
    then obtain pc where pc: "pc < size τs" and x: "τs!pc = x"
      by (simp add: that [of "size xs"] nth_append)
    
    from pres cert wtl s0 pc 
    have "wtl (take pc ins) c 0 s0  A" by (auto intro!: wtl_pres)
    moreover
    from pc have "pc < size ins" by simp
    with cert have "c!pc  A" ..
    ultimately
    have "τs!pc  A" using pc by (simp add: phi_def)
    hence "x  A" using x by simp
  } 
  hence "set τs  A" ..
  thus ?thesis by (unfold list_def) simp
qed
(*>*)

lemma (in lbvs) phi0:
  assumes wtl: "wtl ins c 0 s0  " and 0: "0 < size ins"
  shows "s0 ⊑⇩r τs!0"
(*<*)
proof (cases "c!0 = ")
  case True
  with 0 have "τs!0 = wtl (take 0 ins) c 0 s0" ..
  moreover have "wtl (take 0 ins) c 0 s0 = s0" by simp
  ultimately have "τs!0 = s0" by simp
  thus ?thesis by simp
next
  case False
  with 0 have "τs!0 = c!0" ..
  moreover 
  have "wtl (take 1 ins) c 0 s0  " using wtl by (rule wtl_take)
  with 0 False 
  have "s0 ⊑⇩r c!0" by (auto simp add: neq_Nil_conv wtc split: if_split_asm)
  ultimately
  show ?thesis by simp
qed
(*>*)


theorem (in lbvs) wtl_sound:
  assumes wtl: "wtl ins c 0 s0  " and s0: "s0  A" 
  shows "τs. wt_step r  step τs"
(*<*)
proof -
  have "wt_step r  step τs"
  proof (unfold wt_step_def, intro strip conjI)
    fix pc assume "pc < size τs"
    then obtain pc: "pc < size ins" by simp
    with wtl show "τs!pc  " by (rule phi_not_top)
    from wtl s0 pc show "stable r step τs pc" by (rule wtl_stable)
  qed
  thus ?thesis ..
qed
(*>*)


theorem (in lbvs) wtl_sound_strong:
  assumes wtl: "wtl ins c 0 s0  " 
  assumes s0: "s0  A" and ins: "0 < size ins"
  shows "τs  list (size ins) A. wt_step r  step τs  s0 ⊑⇩r τs!0"
(*<*)
proof -
  have "τs  list (size ins) A" using wtl s0 by (rule phi_in_A)
  moreover
  have "wt_step r  step τs"
  proof (unfold wt_step_def, intro strip conjI)
    fix pc assume "pc < size τs"
    then obtain pc: "pc < size ins" by simp
    with wtl show "τs!pc  " by (rule phi_not_top)
    from wtl s0 and pc show "stable r step τs pc" by (rule wtl_stable)
  qed
  moreover from wtl ins have "s0 ⊑⇩r τs!0" by (rule phi0)
  ultimately show ?thesis by fast
qed
(*>*)

end

Theory LBVComplete

(*  Title:      HOL/MicroJava/BV/LBVComplete.thy
    Author:     Gerwin Klein
    Copyright   2000 Technische Universitaet Muenchen
*)

section ‹Completeness of the LBV›

theory LBVComplete
imports LBVSpec Typing_Framework
begin

definition is_target :: "'s step_type  's list  nat  bool" where
  "is_target step τs pc'  (pc s'. pc'  pc+1  pc < size τs  (pc',s')  set (step pc (τs!pc)))"

definition make_cert :: "'s step_type  's list  's  's certificate" where
  "make_cert step τs B = map (λpc. if is_target step τs pc then τs!pc else B) [0..<size τs] @ [B]"

lemma [code]:
  "is_target step τs pc' =
  list_ex (λpc. pc'  pc+1  List.member (map fst (step pc (τs!pc))) pc') [0..<size τs]"
(*<*)
  apply (simp add: list_ex_iff is_target_def member_def)
  apply force
  done
(*>*)

locale lbvc = lbv + 
  fixes τs :: "'a list" 
  fixes c :: "'a list" 
  defines cert_def: "c  make_cert step τs "

  assumes mono: "mono r step (size τs) A"
  assumes pres: "pres_type step (size τs) A" 
  assumes τs:  "pc < size τs. τs!pc  A  τs!pc  "
  assumes bounded: "bounded step (size τs)"

  assumes B_neq_T: "  " 


lemma (in lbvc) cert: "cert_ok c (size τs)   A"
(*<*)
proof (unfold cert_ok_def, intro strip conjI)  
  note [simp] = make_cert_def cert_def nth_append 

  show "c!size τs = " by simp

  fix pc assume pc: "pc < size τs" 
  from pc τs B_A show "c!pc  A" by simp
  from pc τs B_neq_T show "c!pc  " by simp
qed
(*>*)

lemmas [simp del] = split_paired_Ex

lemma (in lbvc) cert_target [intro?]:
  " (pc',s')  set (step pc (τs!pc));
      pc'  pc+1; pc < size τs; pc' < size τs 
   c!pc' = τs!pc'"
(*<*) by (auto simp add: cert_def make_cert_def nth_append is_target_def) (*>*)

lemma (in lbvc) cert_approx [intro?]:
  " pc < size τs; c!pc     c!pc = τs!pc"
(*<*) by (auto simp add: cert_def make_cert_def nth_append) (*>*)

lemma (in lbv) le_top [simp, intro]: "x <=_r "
(*<*) by (insert top) simp (*>*)
  
lemma (in lbv) merge_mono:
  assumes less:  "set ss2 {⊑r} set ss1"
  assumes x:     "x  A"
  assumes ss1:   "snd`set ss1  A"
  assumes ss2:   "snd`set ss2  A"
  shows "merge c pc ss2 x ⊑⇩r merge c pc ss1 x" (is "?s2 ⊑⇩r ?s1")
(*<*)
proof-
  have "?s1 =   ?thesis" by simp
  moreover {
    assume merge: "?s1  T" 
    from x ss1 have "?s1 =
      (if (pc',s')set ss1. pc'  pc + 1  s' ⊑⇩r c!pc'
      then (map snd [(p', t')  ss1 . p'=pc+1])f x
      else )" by (rule merge_def)  
    with merge obtain
      app: "(pc',s')set ss1. pc'  pc+1  s' ⊑⇩r c!pc'" 
           (is "?app ss1") and
      sum: "(map snd [(p',t')  ss1 . p' = pc+1]f x) = ?s1" 
           (is "?map ss1f x = _" is "?sum ss1 = _")
      by (simp split: if_split_asm)
    from app less have "?app ss2" by (blast dest: trans_r lesub_step_typeD)
    moreover {
      from ss1 have map1: "set (?map ss1)  A" by auto
      with x and semilat Semilat_axioms have "?sum ss1  A" by (auto intro!: plusplus_closed)
      with sum have "?s1  A" by simp
      moreover    
      have mapD: "x ss. x  set (?map ss)  p. (p,x)  set ss  p=pc+1" by auto
      from x map1 have "x  set (?map ss1). x ⊑⇩r ?sum ss1" by clarify (rule pp_ub1)
      with sum have "x  set (?map ss1). x ⊑⇩r ?s1" by simp
      with less have "x  set (?map ss2). x ⊑⇩r ?s1"
        by (fastforce dest!: mapD lesub_step_typeD intro: trans_r)
      moreover from map1 x have "x ⊑⇩r (?sum ss1)" by (rule pp_ub2)
      with sum have "x ⊑⇩r ?s1" by simp
      moreover from ss2 have "set (?map ss2)  A" by auto
      ultimately  have "?sum ss2 ⊑⇩r ?s1" using x by - (rule pp_lub)
    }
    moreover from x ss2 have "?s2 =
      (if (pc', s')set ss2. pc'  pc + 1  s' ⊑⇩r c!pc'
      then map snd [(p', t')  ss2 . p' = pc + 1]f x
      else )" by (rule merge_def)
    ultimately have ?thesis by simp
  }
  ultimately show ?thesis by (cases "?s1 = ") auto
qed
(*>*)

lemma (in lbvc) wti_mono:
  assumes less: "s2 ⊑⇩r s1"
  assumes pc: "pc < size τs" and s1: "s1  A" and s2: "s2  A"
  shows "wti c pc s2 ⊑⇩r wti c pc s1" (is "?s2' ⊑⇩r ?s1'")
(*<*)
proof -
  from mono pc s2 less have "set (step pc s2) {⊑r} set (step pc s1)" by (rule monoD)
  moreover from cert B_A pc have "c!Suc pc  A" by (rule cert_okD3)
  moreover from pres s1 pc have "snd`set (step pc s1)  A" by (rule pres_typeD2)
  moreover from pres s2 pc have "snd`set (step pc s2)  A" by (rule pres_typeD2)
  ultimately show ?thesis by (simp add: wti merge_mono)
qed 
(*>*)

lemma (in lbvc) wtc_mono:
  assumes less: "s2 ⊑⇩r s1"
  assumes pc: "pc < size τs" and s1: "s1  A" and s2: "s2  A"
  shows "wtc c pc s2 ⊑⇩r wtc c pc s1" (is "?s2' ⊑⇩r ?s1'")
(*<*)
proof (cases "c!pc = ")
  case True 
  moreover from less pc s1 s2 have "wti c pc s2 ⊑⇩r wti c pc s1" by (rule wti_mono)
  ultimately show ?thesis by (simp add: wtc)
next
  case False
  have "?s1' =   ?thesis" by simp
  moreover {
    assume "?s1'  " 
    with False have c: "s1 ⊑⇩r c!pc" by (simp add: wtc split: if_split_asm)
    with less have "s2 ⊑⇩r c!pc" ..
    with False c have ?thesis by (simp add: wtc)
  }
  ultimately show ?thesis by (cases "?s1' = ") auto
qed
(*>*)

lemma (in lbv) top_le_conv [simp]: " ⊑⇩r x = (x = )"
(*<*) by (insert semilat) (simp add: top top_le_conv)  (*>*)

lemma (in lbv) neq_top [simp, elim]: " x ⊑⇩r y; y     x  "
(*<*) by (cases "x = T") auto (*>*)

lemma (in lbvc) stable_wti:
  assumes stable:  "stable r step τs pc" and pc: "pc < size τs"
  shows "wti c pc (τs!pc)  "
(*<*)
proof -
  let ?step = "step pc (τs!pc)"
  from stable 
  have less: "(q,s')set ?step. s' ⊑⇩r τs!q" by (simp add: stable_def)
  
  from cert B_A pc have cert_suc: "c!Suc pc  A" by (rule cert_okD3)
  moreover from τs pc have "τs!pc  A" by simp
  with pres pc have stepA: "snd`set ?step  A" by - (rule pres_typeD2)
  ultimately
  have "merge c pc ?step (c!Suc pc) =
    (if (pc',s')set ?step. pc'pc+1  s' ⊑⇩r c!pc'
    then map snd [(p',t')  ?step.p'=pc+1]f c!Suc pc
    else )" unfolding mrg_def by (rule lbv.merge_def [OF lbvc.axioms(1), OF lbvc_axioms])
  moreover {
    fix pc' s' assume s': "(pc',s')  set ?step" and suc_pc: "pc'  pc+1"
    with less have "s' ⊑⇩r τs!pc'" by auto
    also from bounded pc s' have "pc' < size τs" by (rule boundedD)
    with s' suc_pc pc have "c!pc' = τs!pc'" ..
    hence "τs!pc' = c!pc'" ..
    finally have "s' ⊑⇩r c!pc'" .
  } hence "(pc',s')set ?step. pc'pc+1  s' ⊑⇩r c!pc'" by auto
  moreover from pc have "Suc pc = size τs  Suc pc < size τs" by auto
  hence "map snd [(p',t')  ?step.p'=pc+1]f c!Suc pc  " (is "?mapf _  _")
  proof (rule disjE)
    assume pc': "Suc pc = size τs"
    with cert have "c!Suc pc = " by (simp add: cert_okD2)
    moreover 
    from pc' bounded pc 
    have "(p',t')set ?step. p'pc+1" by clarify (drule boundedD, auto)
    hence "[(p',t')  ?step. p'=pc+1] = []" by (blast intro: filter_False)
    hence "?map = []" by simp
    ultimately show ?thesis by (simp add: B_neq_T)
  next
    assume pc': "Suc pc < size τs"
    from pc' τs have "τs!Suc pc  A" by simp
    moreover note cert_suc
    moreover from stepA have "set ?map  A" by auto
    moreover have "s. s  set ?map  t. (Suc pc, t)  set ?step" by auto
    with less have "s'  set ?map. s' ⊑⇩r τs!Suc pc" by auto
    moreover from pc' have "c!Suc pc ⊑⇩r τs!Suc pc" 
      by (cases "c!Suc pc = ") (auto dest: cert_approx)
    ultimately have "?mapf c!Suc pc ⊑⇩r τs!Suc pc" by (rule pp_lub)
    moreover from pc' τs have "τs!Suc pc  " by simp
    ultimately show ?thesis by auto
  qed
  ultimately have "merge c pc ?step (c!Suc pc)  " by simp
  thus ?thesis by (simp add: wti)  
qed
(*>*)

lemma (in lbvc) wti_less:
  assumes stable: "stable r step τs pc" and suc_pc: "Suc pc < size τs"
  shows "wti c pc (τs!pc) ⊑⇩r τs!Suc pc" (is "?wti ⊑⇩r _")
(*<*)
proof -
  let ?step = "step pc (τs!pc)"

  from stable
  have less: "(q,s')set ?step. s' ⊑⇩r τs!q" by (simp add: stable_def)
   
  from suc_pc have pc: "pc < size τs" by simp
  with cert B_A have cert_suc: "c!Suc pc  A" by (rule cert_okD3)
  moreover from τs pc have "τs!pc  A" by simp
  with pres pc have stepA: "snd`set ?step  A" by - (rule pres_typeD2)
  moreover from stable pc have "?wti  " by (rule stable_wti)
  hence "merge c pc ?step (c!Suc pc)  " by (simp add: wti)
  ultimately
  have "merge c pc ?step (c!Suc pc) =
    map snd [(p',t')  ?step.p'=pc+1]f c!Suc pc" by (rule merge_not_top_s) 
  hence "?wti = " (is "_ = (?mapf _)" is "_ = ?sum") by (simp add: wti)
  also {
    from suc_pc τs have "τs!Suc pc  A" by simp
    moreover note cert_suc
    moreover from stepA have "set ?map  A" by auto
    moreover have "s. s  set ?map  t. (Suc pc, t)  set ?step" by auto
    with less have "s'  set ?map. s' ⊑⇩r τs!Suc pc" by auto
    moreover from suc_pc have "c!Suc pc ⊑⇩r τs!Suc pc"
      by (cases "c!Suc pc = ") (auto dest: cert_approx)
    ultimately have "?sum ⊑⇩r τs!Suc pc" by (rule pp_lub)
  }
  finally show ?thesis .
qed
(*>*)

lemma (in lbvc) stable_wtc:
  assumes stable: "stable r step τs pc" and pc: "pc < size τs"
  shows "wtc c pc (τs!pc)  "
(*<*)
proof -
  from stable pc have wti: "wti c pc (τs!pc)  " by (rule stable_wti)
  show ?thesis
  proof (cases "c!pc = ")
    case True with wti show ?thesis by (simp add: wtc)
  next
    case False
    with pc have "c!pc = τs!pc" ..    
    with False wti show ?thesis by (simp add: wtc)
  qed
qed
(*>*)

lemma (in lbvc) wtc_less:
  assumes stable: "stable r step τs pc" and suc_pc: "Suc pc < size τs"
  shows "wtc c pc (τs!pc) ⊑⇩r τs!Suc pc" (is "?wtc ⊑⇩r _")
(*<*)
proof (cases "c!pc = ")
  case True
  moreover from stable suc_pc have "wti c pc (τs!pc) ⊑⇩r τs!Suc pc" by (rule wti_less)
  ultimately show ?thesis by (simp add: wtc)
next
  case False
  from suc_pc have pc: "pc < size τs" by simp
  with stable have "?wtc  " by (rule stable_wtc)
  with False have "?wtc = wti c pc (c!pc)" 
    by (unfold wtc) (simp split: if_split_asm)
  also from pc False have "c!pc = τs!pc" .. 
  finally have "?wtc = wti c pc (τs!pc)" .
  also from stable suc_pc have "wti c pc (τs!pc) ⊑⇩r τs!Suc pc" by (rule wti_less)
  finally show ?thesis .
qed
(*>*)

lemma (in lbvc) wt_step_wtl_lemma:
  assumes wt_step: "wt_step r  step τs"
  shows "pc s. pc+size ls = size τs  s ⊑⇩r τs!pc  s  A  s 
                wtl ls c pc s  "
  (is "pc s. _  _  _  _  ?wtl ls pc s  _")
(*<*)
proof (induct ls)
  fix pc s assume "s" thus "?wtl [] pc s  " by simp
next
  fix pc s i ls
  assume "pc s. pc+size ls=size τs  s ⊑⇩r τs!pc  s  A  s  
                  ?wtl ls pc s  "
  moreover
  assume pc_l: "pc + size (i#ls) = size τs"
  hence suc_pc_l: "Suc pc + size ls = size τs" by simp
  ultimately
  have IH: "s. s ⊑⇩r τs!Suc pc  s  A  s    ?wtl ls (Suc pc) s  " .

  from pc_l obtain pc: "pc < size τs" by simp
  with wt_step have stable: "stable r step τs pc" by (simp add: wt_step_def)
  moreover note pc
  ultimately have wt_τs: "wtc c pc (τs!pc)  " by (rule stable_wtc)

  assume s_τs: "s ⊑⇩r τs!pc"
  assume sA: "s  A"
  from τs pc have τs_pc: "τs!pc  A" by simp
  from s_τs pc τs_pc sA have wt_s_τs: "wtc c pc s ⊑⇩r wtc c pc (τs!pc)" by (rule wtc_mono)
  with wt_τs have wt_s: "wtc c pc s  " by simp
  moreover assume s: "s  " 
  ultimately have "ls = []  ?wtl (i#ls) pc s  " by simp
  moreover {
    assume "ls  []" 
    with pc_l have suc_pc: "Suc pc < size τs" by (auto simp add: neq_Nil_conv)
    with stable have "wtc c pc (τs!pc) ⊑⇩r τs!Suc pc" by (rule wtc_less)
    with wt_s_τs have "wtc c pc s ⊑⇩r τs!Suc pc" by (rule trans_r)      
    moreover from cert suc_pc have "c!pc  A" "c!(pc+1)  A" 
      by (auto simp add: cert_ok_def)
    from pres this sA pc have "wtc c pc s  A" by (rule wtc_pres)
    ultimately have "?wtl ls (Suc pc) (wtc c pc s)  " using IH wt_s by blast
    with s wt_s have "?wtl (i#ls) pc s  " by simp 
  }
  ultimately show "?wtl (i#ls) pc s  " by (cases ls) blast+
qed
(*>*)

theorem (in lbvc) wtl_complete:
  assumes wt: "wt_step r  step τs"
  assumes s: "s ⊑⇩r τs!0" "s  A" "s  " and eq: "size ins = size τs"
  shows "wtl ins c 0 s  "
(*<*)
proof -  
  from eq have "0+size ins = size τs" by simp
  from wt this s show ?thesis by (rule wt_step_wtl_lemma)
qed
(*>*)

end

Theory Abstract_BV

(*  Title:      HOL/MicroJava/BV/Semilat.thy
    Author:     Gerwin Klein
    Copyright   2003 TUM

Abstract Bytecode Verifier.
*)
(*<*)
theory Abstract_BV
imports Typing_Framework_err Kildall LBVCorrect LBVComplete
begin

end
(*>*)

Theory Type

(*  Title:      JinjaThreads/Common/Type.thy
    Author:     David von Oheimb, Tobias Nipkow, Andreas Lochbihler

    Based on the Jinja theory Common/Type.thy by David von Oheimb and Tobias Nipkow
*)

chapter ‹Concepts for all JinjaThreads Languages \label{cha:j}›

section ‹JinjaThreads types›

theory Type
imports
  "../Basic/Auxiliary"
begin

type_synonym cname = String.literal ― ‹class names›
type_synonym mname = String.literal ― ‹method name›
type_synonym vname = String.literal ― ‹names for local/field variables›

definition Object :: cname
where "Object  STR ''java/lang/Object''"

definition Thread :: cname
where "Thread  STR ''java/lang/Thread''"

definition Throwable :: cname
where "Throwable  STR ''java/lang/Throwable''"

definition this :: vname
where "this  STR ''this''"

definition run :: mname
where "run  STR ''run()V''"

definition start :: mname
where "start  STR ''start()V''"

definition wait :: mname
where "wait  STR ''wait()V''"

definition notify :: mname
where "notify  STR ''notify()V''"

definition notifyAll :: mname
where "notifyAll  STR ''notifyAll()V''"

definition join :: mname
where "join  STR ''join()V''"

definition interrupt :: mname
where "interrupt  STR ''interrupt()V''"

definition isInterrupted :: mname
where "isInterrupted  STR ''isInterrupted()Z''"

(* Method names for Class Object *)

definition hashcode :: mname
where "hashcode = STR ''hashCode()I''"

definition clone :: mname
where "clone = STR ''clone()Ljava/lang/Object;''"

definition print :: mname
where "print = STR ''~print(I)V''"

definition currentThread :: mname
where "currentThread = STR ''~Thread.currentThread()Ljava/lang/Thread;''"

definition interrupted :: mname
where "interrupted = STR ''~Thread.interrupted()Z''"

definition yield :: mname
where "yield = STR ''~Thread.yield()V''"

lemmas identifier_name_defs [code_unfold] =
  this_def run_def start_def wait_def notify_def notifyAll_def join_def interrupt_def isInterrupted_def
  hashcode_def clone_def print_def currentThread_def interrupted_def yield_def

lemma Object_Thread_Throwable_neq [simp]:
  "Thread  Object" "Object  Thread"
  "Object  Throwable" "Throwable  Object"
  "Thread  Throwable" "Throwable  Thread"
by(auto simp add: Thread_def Object_def Throwable_def)

lemma synth_method_names_neq_aux:
  "start  wait" "start  notify" "start  notifyAll" "start  join" "start  interrupt" "start  isInterrupted"
  "start  hashcode" "start  clone" "start  print" "start  currentThread"
  "start  interrupted" "start  yield" "start  run"
  "wait  notify" "wait  notifyAll" "wait  join"  "wait  interrupt" "wait  isInterrupted"
  "wait  hashcode" "wait  clone" "wait  print" "wait  currentThread" 
  "wait  interrupted" "wait  yield"  "wait  run"
  "notify  notifyAll" "notify  join" "notify  interrupt" "notify  isInterrupted"
  "notify  hashcode" "notify  clone" "notify  print" "notify  currentThread"
  "notify  interrupted" "notify  yield" "notify  run"
  "notifyAll  join" "notifyAll  interrupt" "notifyAll  isInterrupted"
  "notifyAll  hashcode" "notifyAll  clone" "notifyAll  print" "notifyAll  currentThread"
  "notifyAll  interrupted" "notifyAll  yield" "notifyAll  run"
  "join  interrupt" "join  isInterrupted"
  "join  hashcode" "join  clone" "join  print" "join  currentThread" 
  "join  interrupted" "join  yield" "join  run"
  "interrupt  isInterrupted"
  "interrupt  hashcode" "interrupt  clone" "interrupt  print" "interrupt  currentThread" 
  "interrupt  interrupted" "interrupt  yield" "interrupt  run"
  "isInterrupted  hashcode" "isInterrupted  clone" "isInterrupted  print" "isInterrupted  currentThread" 
  "isInterrupted  interrupted" "isInterrupted  yield" "isInterrupted  run"
  "hashcode  clone" "hashcode  print" "hashcode  currentThread" 
  "hashcode  interrupted" "hashcode  yield" "hashcode  run"
  "clone  print" "clone  currentThread" 
  "clone  interrupted" "clone  yield" "clone  run"
  "print  currentThread" 
  "print  interrupted" "print  yield" "print  run"
  "currentThread  interrupted" "currentThread  yield" "currentThread  run"
  "interrupted  yield" "interrupted  run"
  "yield  run"
by(simp_all add: identifier_name_defs)

lemmas synth_method_names_neq [simp] = synth_method_names_neq_aux synth_method_names_neq_aux[symmetric]

― ‹types›
datatype ty
  = Void          ― ‹type of statements›
  | Boolean
  | Integer
  | NT            ― ‹null type›
  | Class cname   ― ‹class type›
  | Array ty      ("_⌊⌉" 95) ― ‹array type›

context
  notes [[inductive_internals]]
begin

inductive is_refT :: "ty  bool" where
  "is_refT NT"
| "is_refT (Class C)"
| "is_refT (A⌊⌉)"

declare is_refT.intros[iff]

end

lemmas refTE [consumes 1, case_names NT Class Array] = is_refT.cases

lemma not_refTE [consumes 1, case_names Void Boolean Integer]:
  " ¬is_refT T; T = Void  P; T = Boolean  P; T = Integer  P   P"
by (cases T, auto)

fun ground_type :: "ty  ty" where
  "ground_type (Array T) = ground_type T"
| "ground_type T = T"

abbreviation is_NT_Array :: "ty  bool" where
  "is_NT_Array T  ground_type T = NT"

primrec the_Class :: "ty  cname"
where
  "the_Class (Class C) = C"

primrec the_Array :: "ty  ty"
where
  "the_Array (T⌊⌉) = T"


datatype htype =
  Class_type "cname"
| Array_type "ty" "nat"

primrec ty_of_htype :: "htype  ty"
where
  "ty_of_htype (Class_type C) = Class C"
| "ty_of_htype (Array_type T n) = Array T"

primrec alen_of_htype :: "htype  nat"
where
  "alen_of_htype (Array_type T n) = n"

primrec class_type_of :: "htype  cname"
where 
  "class_type_of (Class_type C) = C"
| "class_type_of (Array_type T n) = Object"

fun class_type_of' :: "ty  cname option"
where 
  "class_type_of' (Class C) = C"
| "class_type_of' (Array T) = Object"
| "class_type_of' _ = None" 

lemma rec_htype_is_case [simp]: "rec_htype = case_htype"
by(auto simp add: fun_eq_iff split: htype.split)

lemma ty_of_htype_eq_convs [simp]:
  shows ty_of_htype_eq_Boolean: "ty_of_htype hT  Boolean"
  and ty_of_htype_eq_Void: "ty_of_htype hT  Void"
  and ty_of_htype_eq_Integer: "ty_of_htype hT  Integer"
  and ty_of_htype_eq_NT: "ty_of_htype hT  NT"
  and ty_of_htype_eq_Class: "ty_of_htype hT = Class C  hT = Class_type C"
  and ty_of_htype_eq_Array: "ty_of_htype hT = Array T  (n. hT = Array_type T n)"
by(case_tac [!] hT) simp_all

lemma class_type_of_eq:
  "class_type_of hT = 
  (case hT of Class_type C  C | Array_type T n  Object)"
by(simp split: htype.split)

lemma class_type_of'_ty_of_htype [simp]:
  "class_type_of' (ty_of_htype hT) = class_type_of hT"
by(cases hT) simp_all

fun is_Array :: "ty  bool"
where
  "is_Array (Array T) = True"
| "is_Array _ = False"

lemma is_Array_conv [simp]: "is_Array T  (U. T = Array U)"
by(cases T) simp_all

fun is_Class :: "ty  bool"
where
  "is_Class (Class C) = True"
| "is_Class _ = False"

lemma is_Class_conv [simp]: "is_Class T  (C. T = Class C)"
by(cases T) simp_all

subsection ‹Code generator setup›

code_pred is_refT .

end

Theory Decl

(*  Title:      JinjaThreads/Common/Decl.thy
    Author:     David von Oheimb, Andreas Lochbihler

    Based on the Jinja theory Common/Decl.thy by David von Oheimb
*)

section ‹Class Declarations and Programs›

theory Decl
imports
  Type
begin

type_synonym volatile = bool

record fmod =
  volatile :: volatile

type_synonym fdecl    = "vname × ty × fmod"        ― ‹field declaration›
type_synonym 'm mdecl = "mname × ty list × ty × 'm"     ― ‹method = name, arg. types, return type, body›
type_synonym 'm mdecl' = "mname × ty list × ty × 'm option"     ― ‹method = name, arg. types, return type, possible body›
type_synonym 'm "class" = "cname × fdecl list × 'm mdecl' list"       ― ‹class = superclass, fields, methods›
type_synonym 'm cdecl = "cname × 'm class"  ― ‹class declaration›

datatype
  'm prog = Program "'m cdecl list" 

translations
  (type) "fdecl"   <= (type) "String.literal × ty × fmod"
  (type) "'c mdecl" <= (type) "String.literal × ty list × ty × 'c"
  (type) "'c mdecl'" <= (type) "String.literal × ty list × ty × 'c option"
  (type) "'c class" <= (type) "String.literal × fdecl list × ('c mdecl) list"
  (type) "'c cdecl" <= (type) "String.literal × ('c class)"

notation (input) None ("Native")

primrec "classes" :: "'m prog  'm cdecl list"
where
  "classes (Program P) = P"

primrec "class" :: "'m prog  cname  'm class"
where
  "class (Program p) = map_of p"

locale prog =
  fixes P :: "'m prog"

definition is_class :: "'m prog  cname  bool"
where
  "is_class P C    class P C  None"

lemma finite_is_class: "finite {C. is_class P C}"
(*<*)
apply(cases P)
apply (unfold is_class_def)
apply (fold dom_def)
apply(simp add: finite_dom_map_of)
done
(*>*)

primrec is_type :: "'m prog  ty  bool"
where
  is_type_void:   "is_type P Void = True"
| is_type_bool:   "is_type P Boolean = True"
| is_type_int:    "is_type P Integer = True"
| is_type_nt:     "is_type P NT = True"
| is_type_class:  "is_type P (Class C) = is_class P C"
| is_type_array:  "is_type P (A⌊⌉) = (case ground_type A of NT  False | Class C  is_class P C | _  True)"

lemma is_type_ArrayD: "is_type P (T⌊⌉)  is_type P T"
by(induct T) auto

lemma is_type_ground_type:
  "is_type P T  is_type P (ground_type T)"
by(induct T)(auto, metis is_type_ArrayD is_type_array)

abbreviation "types" :: "'m prog  ty set"
where "types P  {T. is_type P T}"

abbreviation is_htype :: "'m prog  htype  bool"
where "is_htype P hT  is_type P (ty_of_htype hT)"

subsection ‹Code generation›

lemma is_class_intros [code_pred_intro]:
  "class P C  None  is_class P C"
by(auto simp add: is_class_def)

code_pred 
  (modes: i ⇒ i ⇒ bool)
  is_class 
unfolding is_class_def by simp

declare is_class_def[code]

end

Theory TypeRel

(*  Title:      JinjaThreads/Common/TypeRel.thy
    Author:     Tobias Nipkow, Andreas Lochbihler

    Based on the Jinja theory Common/Type.thy by Tobias Nipkow
*)

section ‹Relations between Jinja Types›

theory TypeRel
imports
  Decl
begin

subsection‹The subclass relations›

inductive subcls1 :: "'m prog  cname  cname  bool" ("_  _ 1 _" [71, 71, 71] 70)
  for P :: "'m prog"
where subcls1I: " class P C = Some (D, rest); C  Object   P  C 1 D"

abbreviation subcls :: "'m prog  cname  cname  bool" ("_  _ * _"  [71,71,71] 70)
where "P  C * D  (subcls1 P)** C D"

lemma subcls1D:
  "P  C 1 D  C  Object  (fs ms. class P C = Some (D,fs,ms))"
by(auto elim: subcls1.cases)

lemma Object_subcls1 [iff]: "¬ P  Object 1 C"
by(simp add: subcls1.simps)

lemma Object_subcls_conv [iff]: "(P  Object * C) = (C = Object)"
by(auto elim: converse_rtranclpE)

lemma finite_subcls1: "finite {(C, D). P  C 1 D}"
proof -
  let ?A = "SIGMA C:{C. is_class P C}. {D. CObject  fst (the (class P C))=D}"
  have "finite ?A" by(rule finite_SigmaI [OF finite_is_class]) auto
  also have "?A = {(C, D). P  C 1 D}"
    by(fastforce simp:is_class_def dest: subcls1D elim: subcls1I)
  finally show ?thesis .
qed

lemma finite_subcls1':
  "finite ({(D, C). P  C 1 D})"
by(subst finite_converse[symmetric])
  (simp add: converse_unfold finite_subcls1 del: finite_converse)

lemma subcls_is_class: "(subcls1 P)++ C D  is_class P C"
by(auto elim: converse_tranclpE dest!: subcls1D simp add: is_class_def)

lemma subcls_is_class1: " P  C * D; is_class P D   is_class P C"
by(auto elim: converse_rtranclpE dest!: subcls1D simp add: is_class_def)

subsection‹The subtype relations›

inductive widen :: "'m prog  ty  ty  bool" ("_  _  _"   [71,71,71] 70)
  for P :: "'m prog"
where 
  widen_refl[iff]: "P  T  T"
| widen_subcls: "P  C * D    P  Class C  Class D"
| widen_null[iff]: "P  NT  Class C"
| widen_null_array[iff]: "P  NT  Array A"
| widen_array_object: "P  Array A  Class Object"
| widen_array_array: "P  A  B  P  Array A  Array B"

abbreviation
  widens :: "'m prog  ty list  ty list  bool" ("_  _ [≤] _" [71,71,71] 70)
where
  "P  Ts [≤] Ts' == list_all2 (widen P) Ts Ts'"

lemma [iff]: "(P  T  Void) = (T = Void)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P  T  Boolean) = (T = Boolean)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P  T  Integer) = (T = Integer)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P  Void  T) = (T = Void)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P  Boolean  T) = (T = Boolean)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P  Integer  T) = (T = Integer)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma Class_widen: "P  Class C  T    D. T = Class D"
by(erule widen.cases, auto)

lemma Array_Array_widen:
  "P  Array T  Array U  P  T  U"
by(auto elim: widen.cases)

lemma widen_Array: "(P  T  U⌊⌉)  (T = NT  (V. T = V⌊⌉  P  V  U))"
by(induct T)(auto dest: Array_Array_widen elim: widen.cases intro: widen_array_array)

lemma Array_widen: "P  Array A  T  (B. T = Array B  P  A  B)  T = Class Object"
by(auto elim: widen.cases)

lemma [iff]: "(P  T  NT) = (T = NT)"
by(induct T)(auto dest:Class_widen Array_widen)

lemma Class_widen_Class [iff]: "(P  Class C  Class D) = (P  C * D)"
by (auto elim: widen_subcls widen.cases)

lemma widen_Class: "(P  T  Class C) = (T = NT  (D. T = Class D  P  D * C)  (C = Object  (A. T = Array A)))"
by(induct T)(auto dest: Array_widen intro: widen_array_object)

lemma NT_widen:
  "P  NT  T = (T = NT  (C. T = Class C)  (U. T = U⌊⌉))"
by(cases T) auto

lemma Class_widen2: "P  Class C  T = (D. T = Class D  P  C * D)"
by (cases T, auto elim: widen.cases)

lemma Object_widen: "P  Class Object  T  T = Class Object"
by(cases T, auto elim: widen.cases)

lemma NT_Array_widen_Object:
  "is_NT_Array T   P  T  Class Object"
by(induct T, auto intro: widen_array_object)

lemma widen_trans[trans]: 
  assumes "P  S  U" "P  U  T"
  shows "P  S  T"
using assms
proof(induct arbitrary: T)
  case (widen_refl T T') thus "P  T  T'" .
next
  case (widen_subcls C D T)
  then obtain E where "T = Class E" by (blast dest: Class_widen)
  with widen_subcls show "P  Class C  T" by (auto elim: rtrancl_trans)
next
  case (widen_null C RT)
  then obtain D where "RT = Class D" by (blast dest: Class_widen)
  thus "P  NT  RT" by auto
next
  case widen_null_array thus ?case by(auto dest: Array_widen)
next
  case (widen_array_object A T)
  hence "T = Class Object" by(rule Object_widen)
  with widen_array_object show "P  A⌊⌉  T"
    by(auto intro: widen.widen_array_object)
next
  case widen_array_array thus ?case
    by(auto dest!: Array_widen intro: widen.widen_array_array widen_array_object)
qed

lemma widens_trans: "P  Ss [≤] Ts; P  Ts [≤] Us  P  Ss [≤] Us"
by (rule list_all2_trans)(rule widen_trans)

lemma class_type_of'_widenD:
  "class_type_of' T = C  P  T  Class C"
by(cases T)(auto intro: widen_array_object)

lemma widen_is_class_type_of:
  assumes "class_type_of' T = C" "P  T'  T" "T'  NT"
  obtains C' where "class_type_of' T' = C'" "P  C' * C"
using assms by(cases T)(auto simp add: widen_Class widen_Array)

lemma widens_refl: "P  Ts [≤] Ts"
by(rule list_all2_refl[OF widen_refl])

lemma widen_append1:
  "P  (xs @ ys) [≤] Ts = (Ts1 Ts2. Ts = Ts1 @ Ts2  length xs = length Ts1  length ys = length Ts2  P  xs [≤] Ts1  P  ys [≤] Ts2)"
unfolding list_all2_append1 by fastforce

lemmas widens_Cons [iff] = list_all2_Cons1 [of "widen P"] for P

lemma widens_lengthD:
  "P  xs [≤] ys  length xs = length ys"
by(rule list_all2_lengthD)

lemma widen_refT: " is_refT T; P  U  T   is_refT U"
by(erule refTE)(auto simp add: widen_Class widen_Array)

lemma refT_widen: " is_refT T; P  T  U   is_refT U"
by(erule widen.cases) auto

inductive is_lub :: "'m prog  ty  ty  ty  bool" ("_  lub'((_,/ _)') = _" [51,51,51,51] 50)
for P :: "'m prog" and U :: ty and V :: ty and T ::  ty
where 
  " P  U  T; P  V  T;
     T'.  P  U  T'; P  V  T'   P  T  T' 
   P  lub(U, V) = T"

lemma is_lub_upper:
  "P  lub(U, V) = T  P  U  T  P  V  T"
by(auto elim: is_lub.cases)

lemma is_lub_least:
  " P  lub(U, V) = T; P  U  T'; P  V  T'   P  T  T'"
by(auto elim: is_lub.cases)

lemma is_lub_Void [iff]:
  "P  lub(Void, Void) = T  T = Void"
by(auto intro: is_lub.intros elim: is_lub.cases)

lemma is_lubI [code_pred_intro]:
  "P  U  T; P  V  T; T'. P  U  T'  P  V  T'  P  T  T'  P  lub(U, V) = T"
by(blast intro: is_lub.intros)

subsection‹Method lookup›

inductive Methods :: "'m prog  cname  (mname  (ty list × ty × 'm option) × cname)  bool" 
  ("_  _ sees'_methods _" [51,51,51] 50)
  for P :: "'m prog"
where 
sees_methods_Object:
 " class P Object = Some(D,fs,ms); Mm = map_option (λm. (m,Object))  map_of ms 
   P  Object sees_methods Mm"
| sees_methods_rec:
 " class P C = Some(D,fs,ms); C  Object; P  D sees_methods Mm;
    Mm' = Mm ++ (map_option (λm. (m,C))  map_of ms) 
   P  C sees_methods Mm'"

lemma sees_methods_fun:
  assumes "P  C sees_methods Mm"
  shows "P  C sees_methods Mm'  Mm' = Mm"
using assms
proof(induction arbitrary: Mm')
  case sees_methods_Object thus ?case by(auto elim: Methods.cases)
next
  case (sees_methods_rec C D fs ms Dres Cres Cres')
  from P  C sees_methods Cres' C  Object› ‹class P C = (D, fs, ms)
  obtain Dres' where Dmethods': "P  D sees_methods Dres'"
    and Cres': "Cres' = Dres' ++ (map_option (λm. (m,C))  map_of ms)"
    by cases auto
  from sees_methods_rec.IH[OF Dmethods'] Cres = Dres ++ (map_option (λm. (m,C))  map_of ms) Cres'
  show ?case by simp
qed

lemma visible_methods_exist:
  "P  C sees_methods Mm  Mm M = Some(m,D) 
   (D' fs ms. class P D = Some(D',fs,ms)  map_of ms M = Some m)"
by(induct rule:Methods.induct) auto

lemma sees_methods_decl_above:
  assumes "P  C sees_methods Mm"
  shows "Mm M = Some(m,D)  P  C * D"
using assms
by induct(auto elim: converse_rtranclp_into_rtranclp[where r = "subcls1 P", OF subcls1I])

lemma sees_methods_idemp:
  assumes "P  C sees_methods Mm" and "Mm M = Some(m,D)"
  shows "Mm'. (P  D sees_methods Mm')  Mm' M = Some(m,D)"
using assms
by(induct arbitrary: m D)(fastforce dest: Methods.intros)+

lemma sees_methods_decl_mono:
  assumes sub: "P  C' * C" and "P  C sees_methods Mm"
  shows "Mm' Mm2. P  C' sees_methods Mm'  Mm' = Mm ++ Mm2  (M m D. Mm2 M = Some(m,D)  P  D * C)"
      (is "Mm' Mm2. ?Q C' C Mm' Mm2")
using assms
proof (induction rule: converse_rtranclp_induct)
  case base
  hence "?Q C C Mm Map.empty" by simp
  thus "Mm' Mm2. ?Q C C Mm' Mm2" by blast
next
  case (step C'' C')
  note sub1 = P  C'' 1 C' and sub = P  C' * C
    and Csees = P  C sees_methods Mm
  from step.IH[OF Csees] obtain Mm' Mm2 where C'sees: "P  C' sees_methods Mm'"
    and Mm': "Mm' = Mm ++ Mm2"
    and subC: "M m D. Mm2 M = Some(m,D)  P  D * C" by blast
  obtain fs ms where "class": "class P C'' = Some(C',fs,ms)" "C''  Object"
    using subcls1D[OF sub1] by blast
  let ?Mm3 = "map_option (λm. (m,C''))  map_of ms"
  have "P  C'' sees_methods (Mm ++ Mm2) ++ ?Mm3"
    using sees_methods_rec[OF "class" C'sees refl] Mm' by simp
  hence "?Q C'' C ((Mm ++ Mm2) ++ ?Mm3) (Mm2++?Mm3)"
    using converse_rtranclp_into_rtranclp[OF sub1 sub]
    by simp (simp add:map_add_def subC split:option.split)
  thus "Mm' Mm2. ?Q C'' C Mm' Mm2" by blast
qed

definition Method :: "'m prog  cname  mname  ty list  ty  'm option  cname  bool"
            ("_  _ sees _: __ = _ in _" [51,51,51,51,51,51,51] 50)
where
  "P  C sees M: TsT = m in D  
  Mm. P  C sees_methods Mm  Mm M = Some((Ts,T,m),D)"

text ‹
  Output translation to replace @{term "None"} with its notation Native›
  when used as method body in @{term "Method"}.
›
abbreviation (output)
  Method_native :: "'m prog  cname  mname  ty list  ty  cname  bool"
  ("_  _ sees _: __ = Native in _" [51,51,51,51,51,51] 50)
where "Method_native P C M Ts T D  Method P C M Ts T Native D"

definition has_method :: "'m prog  cname  mname  bool" ("_  _ has _" [51,0,51] 50)
where
  "P  C has M  Ts T m D. P  C sees M:TsT = m in D"

lemma has_methodI:
  "P  C sees M:TsT = m in D  P  C has M"
  by (unfold has_method_def) blast

lemma sees_method_fun:
  "P  C sees M:TST = m in D; P  C sees M:TS'T' = m' in D' 
    TS' = TS  T' = T  m' = m  D' = D"
 (*<*)by(fastforce dest: sees_methods_fun simp:Method_def)(*>*)

lemma sees_method_decl_above:
  "P  C sees M:TsT = m in D  P  C * D"
 (*<*)by(clarsimp simp:Method_def sees_methods_decl_above)(*>*)

lemma visible_method_exists:
  "P  C sees M:TsT = m in D 
  D' fs ms. class P D = Some(D',fs,ms)  map_of ms M = Some(Ts,T,m)"
(*<*)by(fastforce simp:Method_def dest!: visible_methods_exist)(*>*)


lemma sees_method_idemp:
  "P  C sees M:TsT=m in D  P  D sees M:TsT=m in D"
 (*<*)by(fastforce simp: Method_def intro:sees_methods_idemp)(*>*)

lemma sees_method_decl_mono:
  " P  C' * C; P  C sees M:TsT = m in D;
     P  C' sees M:Ts'T' = m' in D'   P  D' * D"
apply(frule sees_method_decl_above)
apply(unfold Method_def)
apply clarsimp
apply(drule (1) sees_methods_decl_mono)
apply clarsimp
apply(drule (1) sees_methods_fun)
apply clarsimp
apply(blast intro:rtranclp_trans)
done

lemma sees_method_is_class:
  "P  C sees M:TsT = m in D  is_class P C"
by (auto simp add: is_class_def Method_def elim: Methods.cases)

subsection‹Field lookup›

inductive Fields :: "'m prog  cname  ((vname × cname) × (ty × fmod)) list  bool"
  ("_  _ has'_fields _" [51,51,51] 50)
  for P :: "'m prog"
where 
  has_fields_rec:
  " class P C = Some(D,fs,ms); C  Object; P  D has_fields FDTs;
     FDTs' = map (λ(F,Tm). ((F,C),Tm)) fs @ FDTs 
    P  C has_fields FDTs'"

| has_fields_Object:
  " class P Object = Some(D,fs,ms); FDTs = map (λ(F,T). ((F,Object),T)) fs 
    P  Object has_fields FDTs"

lemma has_fields_fun:
  assumes "P  C has_fields FDTs" and "P  C has_fields FDTs'"
  shows "FDTs' = FDTs"
using assms
proof(induction arbitrary: FDTs')
  case has_fields_Object thus ?case by(auto elim: Fields.cases)
next
  case (has_fields_rec C D fs ms Dres Cres Cres')
  from P  C has_fields Cres' C  Object› ‹class P C = Some (D, fs, ms)
  obtain Dres' where DFields': "P  D has_fields Dres'"
    and Cres': "Cres' = map (λ(F,Tm). ((F,C),Tm)) fs @ Dres'"
    by cases auto
  from has_fields_rec.IH[OF DFields'] Cres = map (λ(F,Tm). ((F,C),Tm)) fs @ Dres Cres'
  show ?case by simp
qed

lemma all_fields_in_has_fields:
  assumes "P  C has_fields FDTs"
  and "P  C * D" "class P D = Some(D',fs,ms)" "(F,Tm)  set fs"
  shows "((F,D),Tm)  set FDTs"
using assms
by induct (auto 4 3 elim: converse_rtranclpE dest: subcls1D)

lemma has_fields_decl_above:
  assumes "P  C has_fields FDTs" "((F,D),Tm)  set FDTs"
  shows "P  C * D"
using assms
by induct (auto intro: converse_rtranclp_into_rtranclp subcls1I)

lemma subcls_notin_has_fields:
  assumes "P  C has_fields FDTs" "((F,D),Tm)  set FDTs"
  shows "¬ (subcls1 P)++ D C"
using assms apply(induct)
 prefer 2 apply(fastforce dest: tranclpD)
apply clarsimp
apply(erule disjE)
 apply(clarsimp simp add:image_def)
 apply(drule tranclpD)
 apply clarify
 apply(frule subcls1D)
 apply(fastforce dest:tranclpD all_fields_in_has_fields)
apply(blast dest:subcls1I tranclp.trancl_into_trancl)
done

lemma has_fields_mono_lem:
  assumes "P  D * C" "P  C has_fields FDTs"
  shows "pre. P  D has_fields pre@FDTs  dom(map_of pre)  dom(map_of FDTs) = {}"
using assms
apply(induct rule:converse_rtranclp_induct)
 apply(rule_tac x = "[]" in exI)
 apply simp
apply clarsimp
apply(rename_tac D' D pre)
apply(subgoal_tac "(subcls1 P)^++ D' C")
 prefer 2 apply(erule (1) rtranclp_into_tranclp2)
apply(drule subcls1D)
apply clarsimp
apply(rename_tac fs ms)
apply(drule (2) has_fields_rec)
 apply(rule refl)
apply(rule_tac x = "map (λ(F,Tm). ((F,D'),Tm)) fs @ pre" in exI)
apply simp
apply(simp add:Int_Un_distrib2)
apply(rule equals0I)
apply(auto dest: subcls_notin_has_fields simp:dom_map_of_conv_image_fst image_def)
done

lemma has_fields_is_class:
  "P  C has_fields FDTs  is_class P C"
by (auto simp add: is_class_def elim: Fields.cases)

lemma Object_has_fields_Object:
  assumes "P  Object has_fields FDTs"
  shows "snd ` fst ` set FDTs  {Object}"
using assms by cases auto

definition
  has_field :: "'m prog  cname  vname  ty  fmod  cname  bool"
                   ("_  _ has _:_ '(_') in _" [51,51,51,51,51,51] 50)
where
  "P  C has F:T (fm) in D  
  FDTs. P  C has_fields FDTs  map_of FDTs (F,D) = Some (T, fm)"

lemma has_field_mono:
  " P  C has F:T (fm) in D; P  C' * C   P  C' has F:T (fm) in D"
by(fastforce simp:has_field_def map_add_def dest: has_fields_mono_lem)

lemma has_field_is_class:
  "P  C has M:T (fm) in D  is_class P C"
by (auto simp add: is_class_def has_field_def elim: Fields.cases)

lemma has_field_decl_above:
  "P  C has F:T (fm) in D  P  C * D"
unfolding has_field_def
by(auto dest: map_of_SomeD has_fields_decl_above)

lemma has_field_fun:
  "P  C has F:T (fm) in D; P  C has F:T' (fm') in D  T' = T  fm = fm'"
by(auto simp:has_field_def dest:has_fields_fun)

definition
  sees_field :: "'m prog  cname  vname  ty  fmod  cname  bool"
                  ("_  _ sees _:_ '(_') in _" [51,51,51,51,51,51] 50)
where
  "P  C sees F:T (fm) in D  
  FDTs. P  C has_fields FDTs 
            map_of (map (λ((F,D),Tm). (F,(D,Tm))) FDTs) F = Some(D,T,fm)"

lemma map_of_remap_SomeD:
  "map_of (map (λ((k,k'),x). (k,(k',x))) t) k = Some (k',x)  map_of t (k, k') = Some x"
by (induct t) (auto simp:fun_upd_apply split: if_split_asm)

lemma has_visible_field:
  "P  C sees F:T (fm) in D  P  C has F:T (fm) in D"
by(auto simp add:has_field_def sees_field_def map_of_remap_SomeD)

lemma sees_field_fun:
  "P  C sees F:T (fm) in D; P  C sees F:T' (fm') in D'  T' = T  D' = D  fm = fm'"
by(fastforce simp:sees_field_def dest:has_fields_fun)


lemma sees_field_decl_above:
  "P  C sees F:T (fm) in D  P  C * D"
by(clarsimp simp add: sees_field_def)
  (blast intro: has_fields_decl_above map_of_SomeD map_of_remap_SomeD)

lemma sees_field_idemp:
  assumes "P  C sees F:T (fm) in D"
  shows "P  D sees F:T (fm) in D"
proof -
  from assms obtain FDTs where has: "P  C has_fields FDTs"
    and F: "map_of (map (λ((F, D), Tm). (F, D, Tm)) FDTs) F = (D, T, fm)"
    unfolding sees_field_def by blast
  thus ?thesis
  proof induct
    case has_fields_rec thus ?case unfolding sees_field_def
      by(auto)(fastforce dest: map_of_SomeD intro!: exI intro: Fields.has_fields_rec)
  next
    case has_fields_Object thus ?case unfolding sees_field_def
      by(fastforce dest: map_of_SomeD intro: Fields.has_fields_Object intro!: exI)
  qed
qed

subsection "Functional lookup"

definition "method" :: "'m prog  cname  mname  cname × ty list × ty × 'm option"
where "method P C M    THE (D,Ts,T,m). P  C sees M:Ts  T = m in D"

definition field  :: "'m prog  cname  vname  cname × ty × fmod"
where "field P C F    THE (D,T,fm). P  C sees F:T (fm) in D"
                                                        
definition fields :: "'m prog  cname  ((vname × cname) × (ty × fmod)) list" 
where "fields P C    THE FDTs. P  C has_fields FDTs"                

lemma [simp]: "P  C has_fields FDTs  fields P C = FDTs"
(*<*)by (unfold fields_def) (auto dest: has_fields_fun)(*>*)

lemma field_def2 [simp]: "P  C sees F:T (fm) in D  field P C F = (D,T,fm)"
(*<*)by (unfold field_def) (auto dest: sees_field_fun)(*>*)

lemma method_def2 [simp]: "P  C sees M: TsT = m in D  method P C M = (D,Ts,T,m)"
(*<*)by (unfold method_def) (auto dest: sees_method_fun)(*>*)

lemma has_fields_b_fields: 
  "P  C has_fields FDTs  fields P C = FDTs"
unfolding fields_def
by (blast intro: the_equality has_fields_fun)

lemma has_field_map_of_fields [simp]:
  "P  C has F:T (fm) in D  map_of (fields P C) (F, D) = (T, fm)"
by(auto simp add: has_field_def)

subsection ‹Code generation›

text ‹New introduction rules for subcls1›

code_pred
  ― ‹Disallow mode @{text "i_o_o"} to force @{text code_pred} in subsequent predicates not to use this inefficient mode›
  (modes: i ⇒ i ⇒ i ⇒ bool, i ⇒ i ⇒ o ⇒ bool) 
  subcls1
.

text ‹
  Introduce proper constant subcls'› for @{term "subcls"}
  and generate executable equation for subcls'›

definition subcls' where "subcls' = subcls"

code_pred
  (modes: i ⇒ i ⇒ i ⇒ bool, i ⇒ i ⇒ o ⇒ bool)
  [inductify]
  subcls'
.

lemma subcls_conv_subcls' [code_unfold]:
  "(subcls1 P)^** = subcls' P"
by(simp add: subcls'_def)

text ‹
  Change rule @{thm widen_array_object} such that predicate compiler
  tests on class @{term Object} first. Otherwise widen_i_o_i› never terminates.
›

lemma widen_array_object_code:
  "C = Object  P  Array A  Class C"
by(auto intro: widen.intros)

lemmas [code_pred_intro] =
  widen_refl widen_subcls widen_null widen_null_array widen_array_object_code widen_array_array
code_pred 
  (modes: i ⇒ i ⇒ i ⇒ bool)
  widen 
by(erule widen.cases) auto

text ‹
  Readjust the code equations for @{term widen} such that @{term widen_i_i_i} is guaranteed to
  contain @{term "()"} at most once (even in the code representation!). This is important
  for the scheduler and the small-step semantics because of the weaker code equations
  for @{term "the"}.

  A similar problem cannot hit the subclass relation because, for acyclic subclass hierarchies, 
  the paths in the hieararchy are unique and cycle-free.
›

definition widen_i_i_i' where "widen_i_i_i' = widen_i_i_i"

declare widen.equation [code del]
lemmas widen_i_i_i'_equation [code] = widen.equation[folded widen_i_i_i'_def]

lemma widen_i_i_i_code [code]:
  "widen_i_i_i P T T' = (if P  T  T' then Predicate.single () else bot)"
by(auto intro!: pred_eqI intro: widen_i_i_iI elim: widen_i_i_iE)

code_pred 
  (modes: i ⇒ i ⇒ i ⇒ bool, i ⇒ i ⇒ o ⇒ bool)
  Methods 
.

code_pred 
  (modes: i ⇒ i ⇒ i ⇒ o ⇒ o ⇒ o ⇒ o ⇒ bool, i ⇒ i ⇒ i ⇒ o ⇒ o ⇒ o ⇒ i ⇒ bool)
  [inductify]
  Method
.

code_pred 
  (modes: i ⇒ i ⇒ i ⇒ bool)
  [inductify]
  has_method 
.

(* FIXME: Necessary only because of bug in code_pred *)
declare fun_upd_def [code_pred_inline]

code_pred 
  (modes: i ⇒ i ⇒ o ⇒ bool)
  Fields 
.

code_pred
  (modes: i ⇒ i ⇒ i ⇒ o ⇒ o ⇒ i ⇒ bool)
  [inductify, skip_proof]
  has_field
.

code_pred
  (modes: i ⇒ i ⇒ i ⇒ o ⇒ o ⇒ o ⇒ bool, i ⇒ i ⇒ i ⇒ o ⇒ o ⇒ i ⇒ bool)
  [inductify, skip_proof]
  sees_field
.

lemma eval_Method_i_i_i_o_o_o_o_conv:
  "Predicate.eval (Method_i_i_i_o_o_o_o P C M) = (λ(Ts, T, m, D). P  C sees M:TsT=m in D)"
by(auto intro: Method_i_i_i_o_o_o_oI elim: Method_i_i_i_o_o_o_oE intro!: ext)

lemma method_code [code]:
  "method P C M = 
  Predicate.the (Predicate.bind (Method_i_i_i_o_o_o_o P C M) (λ(Ts, T, m, D). Predicate.single (D, Ts, T, m)))"
apply (rule sym, rule the_eqI)
apply (simp add: method_def eval_Method_i_i_i_o_o_o_o_conv)
apply (rule arg_cong [where f=The])
apply (auto simp add: Sup_fun_def Sup_bool_def fun_eq_iff)
done

lemma eval_sees_field_i_i_i_o_o_o_conv:
  "Predicate.eval (sees_field_i_i_i_o_o_o P C F) = (λ(T, fm, D). P  C sees F:T (fm) in D)"
by(auto intro!: ext intro: sees_field_i_i_i_o_o_oI elim: sees_field_i_i_i_o_o_oE)

lemma eval_sees_field_i_i_i_o_i_conv:
  "Predicate.eval (sees_field_i_i_i_o_o_i P C F D) = (λ(T, fm). P  C sees F:T (fm) in D)"
by(auto intro!: ext intro: sees_field_i_i_i_o_o_iI elim: sees_field_i_i_i_o_o_iE)

lemma field_code [code]:
  "field P C F = Predicate.the (Predicate.bind (sees_field_i_i_i_o_o_o P C F) (λ(T, fm, D). Predicate.single (D, T, fm)))"
apply (rule sym, rule the_eqI)
apply (simp add: field_def eval_sees_field_i_i_i_o_o_o_conv)
apply (rule arg_cong [where f=The])
apply (auto simp add: Sup_fun_def Sup_bool_def fun_eq_iff)
done

lemma eval_Fields_conv:
  "Predicate.eval (Fields_i_i_o P C) = (λFDTs. P  C has_fields FDTs)"
by(auto intro: Fields_i_i_oI elim: Fields_i_i_oE intro!: ext)

lemma fields_code [code]:
  "fields P C = Predicate.the (Fields_i_i_o P C)"
by(simp add: fields_def Predicate.the_def eval_Fields_conv)

code_identifier
  code_module TypeRel 
    (SML) TypeRel and (Haskell) TypeRel and (OCaml) TypeRel
| code_module Decl 
    (SML) TypeRel and (Haskell) TypeRel and (OCaml) TypeRel

end

Theory Value

(*  Title:      JinjaThreads/Common/Value.thy
    Author:     David von Oheimb, Tobias Nipkow, Andreas Lochbihler

    Based on the Jinja theory Common/Value.thy by David von Oheimb and Tobias Nipkow
*)

section ‹Jinja Values›

theory Value
imports
  TypeRel
  "HOL-Library.Word"
begin

no_notation floor ("_")

type_synonym word32 = "32 word"

datatype 'addr val
  = Unit          ― ‹dummy result value of void expressions›
  | Null          ― ‹null reference›
  | Bool bool     ― ‹Boolean value›
  | Intg word32   ― ‹integer value› 
  | Addr 'addr    ― ‹addresses of objects, arrays and threads in the heap›

primrec default_val :: "ty  'addr val"   ― ‹default value for all types›
where
  "default_val Void      = Unit"
| "default_val Boolean   = Bool False"
| "default_val Integer   = Intg 0"
| "default_val NT        = Null"
| "default_val (Class C) = Null"
| "default_val (Array A) = Null"

lemma default_val_not_Addr: "default_val T  Addr a"
by(cases T)(simp_all)

lemma Addr_not_default_val: "Addr a  default_val T"
by(cases T)(simp_all)

primrec the_Intg :: "'addr val  word32"
where
  "the_Intg (Intg i) = i"

primrec the_Addr :: "'addr val  'addr"
where
  "the_Addr (Addr a) = a"

fun is_Addr :: "'addr val  bool"
where
  "is_Addr (Addr a) = True"
| "is_Addr _        = False"

lemma is_AddrE [elim!]:
  " is_Addr v; a. v = Addr a  thesis   thesis"
by(cases v, auto)

fun is_Intg :: "'addr val  bool"
where
  "is_Intg (Intg i) = True"
| "is_Intg _        = False"

lemma is_IntgE [elim!]:
  " is_Intg v; i. v = Intg i  thesis   thesis"
by(cases v, auto)

fun is_Bool :: "'addr val  bool"
where
  "is_Bool (Bool b) = True"
| "is_Bool _        = False"

lemma is_BoolE [elim!]:
  " is_Bool v; a. v = Bool a  thesis   thesis"
by(cases v, auto)

definition is_Ref :: "'addr val  bool"
where "is_Ref v  v = Null  is_Addr v"

lemma is_Ref_def2:
  "is_Ref v = (v = Null  (a. v = Addr a))"
  by (cases v) (auto simp add: is_Ref_def)

lemma [iff]: "is_Ref Null" by (simp add: is_Ref_def2)

definition undefined_value :: "'addr val" where "undefined_value = Unit"

lemma undefined_value_not_Addr: 
  "undefined_value  Addr a" "Addr a  undefined_value"
by(simp_all add: undefined_value_def)

class addr =
  fixes hash_addr :: "'a  int"
  and monitor_finfun_to_list :: "('a ⇒f nat)  'a list"
  assumes "set (monitor_finfun_to_list f) = Collect (($) (finfun_dom f))"

locale addr_base =
  fixes addr2thread_id :: "'addr  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"

end

Theory Exceptions

(*  Title:      JinjaThreads/Common/Exceptions.thy
    Author:     Gerwin Klein, Martin Strecker, Andreas Lochbihler

    Based on the Jinja theory Common/Exceptions.thy by Gerwin Klein and Martin Strecker
*)

section ‹Exceptions›

theory Exceptions
imports
  Value
begin

definition NullPointer :: cname
where [code_unfold]: "NullPointer = STR ''java/lang/NullPointerException''"

definition ClassCast :: cname
where [code_unfold]: "ClassCast = STR ''java/lang/ClassCastException''"

definition OutOfMemory :: cname
where [code_unfold]: "OutOfMemory = STR ''java/lang/OutOfMemoryError''"

definition ArrayIndexOutOfBounds :: cname
where [code_unfold]: "ArrayIndexOutOfBounds = STR ''java/lang/ArrayIndexOutOfBoundsException''"

definition ArrayStore :: cname
where [code_unfold]: "ArrayStore = STR ''java/lang/ArrayStoreException''"

definition NegativeArraySize :: cname
where [code_unfold]: "NegativeArraySize = STR ''java/lang/NegativeArraySizeException''"

definition ArithmeticException :: cname
where [code_unfold]: "ArithmeticException = STR ''java/lang/ArithmeticException''"

definition IllegalMonitorState :: cname
where [code_unfold]: "IllegalMonitorState = STR ''java/lang/IllegalMonitorStateException''"

definition IllegalThreadState :: cname
where [code_unfold]: "IllegalThreadState = STR ''java/lang/IllegalThreadStateException''"

definition InterruptedException :: cname
where [code_unfold]: "InterruptedException = STR ''java/lang/InterruptedException''"

definition sys_xcpts_list :: "cname list"
where
  "sys_xcpts_list = 
  [NullPointer, ClassCast, OutOfMemory, ArrayIndexOutOfBounds, ArrayStore, NegativeArraySize, ArithmeticException,
   IllegalMonitorState, IllegalThreadState, InterruptedException]"

definition sys_xcpts :: "cname set"
where [code_unfold]: "sys_xcpts = set sys_xcpts_list"

definition wf_syscls :: "'m prog  bool"
where "wf_syscls P  (C  {Object, Throwable, Thread}. is_class P C)  (C  sys_xcpts. P  C * Throwable)"

subsection "System exceptions"

lemma [simp]:
  "NullPointer  sys_xcpts  
   OutOfMemory  sys_xcpts  
   ClassCast  sys_xcpts  
   ArrayIndexOutOfBounds  sys_xcpts  
   ArrayStore  sys_xcpts  
   NegativeArraySize  sys_xcpts  
   IllegalMonitorState  sys_xcpts 
   IllegalThreadState  sys_xcpts 
   InterruptedException  sys_xcpts 
   ArithmeticException  sys_xcpts"
by(simp add: sys_xcpts_def sys_xcpts_list_def)

lemma sys_xcpts_cases [consumes 1, cases set]:
  " C  sys_xcpts; P NullPointer; P OutOfMemory; P ClassCast; 
     P ArrayIndexOutOfBounds; P ArrayStore; P NegativeArraySize;
     P ArithmeticException;
     P IllegalMonitorState; P IllegalThreadState; P InterruptedException 
   P C"
by (auto simp add: sys_xcpts_def sys_xcpts_list_def)

lemma OutOfMemory_not_Object[simp]: "OutOfMemory  Object"
by(simp add: OutOfMemory_def Object_def)

lemma ClassCast_not_Object[simp]: "ClassCast  Object"
by(simp add: ClassCast_def Object_def)

lemma NullPointer_not_Object[simp]: "NullPointer  Object"
by(simp add: NullPointer_def Object_def)

lemma ArrayIndexOutOfBounds_not_Object[simp]: "ArrayIndexOutOfBounds  Object"
by(simp add: ArrayIndexOutOfBounds_def Object_def)

lemma ArrayStore_not_Object[simp]: "ArrayStore  Object"
by(simp add: ArrayStore_def Object_def)

lemma NegativeArraySize_not_Object[simp]: "NegativeArraySize  Object"
by(simp add: NegativeArraySize_def Object_def)

lemma ArithmeticException_not_Object[simp]: "ArithmeticException  Object"
by(simp add: ArithmeticException_def Object_def)

lemma IllegalMonitorState_not_Object[simp]: "IllegalMonitorState  Object"
by(simp add: IllegalMonitorState_def Object_def)

lemma IllegalThreadState_not_Object[simp]: "IllegalThreadState  Object"
by(simp add: IllegalThreadState_def Object_def)

lemma InterruptedException_not_Object[simp]: "InterruptedException  Object"
by(simp add: InterruptedException_def Object_def)

lemma sys_xcpts_neqs_aux:
  "NullPointer  ClassCast" "NullPointer  OutOfMemory" "NullPointer  ArrayIndexOutOfBounds"
  "NullPointer  ArrayStore" "NullPointer  NegativeArraySize" "NullPointer  IllegalMonitorState"
  "NullPointer  IllegalThreadState" "NullPointer  InterruptedException" "NullPointer  ArithmeticException"
  "ClassCast  OutOfMemory" "ClassCast  ArrayIndexOutOfBounds"
  "ClassCast  ArrayStore" "ClassCast  NegativeArraySize" "ClassCast  IllegalMonitorState"
  "ClassCast  IllegalThreadState" "ClassCast  InterruptedException" "ClassCast  ArithmeticException"
  "OutOfMemory  ArrayIndexOutOfBounds"
  "OutOfMemory  ArrayStore" "OutOfMemory  NegativeArraySize" "OutOfMemory  IllegalMonitorState"
  "OutOfMemory  IllegalThreadState" "OutOfMemory  InterruptedException"
  "OutOfMemory  ArithmeticException"
  "ArrayIndexOutOfBounds  ArrayStore" "ArrayIndexOutOfBounds  NegativeArraySize" "ArrayIndexOutOfBounds  IllegalMonitorState"
  "ArrayIndexOutOfBounds  IllegalThreadState" "ArrayIndexOutOfBounds  InterruptedException" "ArrayIndexOutOfBounds  ArithmeticException"
  "ArrayStore  NegativeArraySize" "ArrayStore  IllegalMonitorState"
  "ArrayStore  IllegalThreadState" "ArrayStore  InterruptedException"
  "ArrayStore  ArithmeticException"
  "NegativeArraySize  IllegalMonitorState"
  "NegativeArraySize  IllegalThreadState" "NegativeArraySize  InterruptedException"
  "NegativeArraySize  ArithmeticException"
  "IllegalMonitorState  IllegalThreadState" "IllegalMonitorState  InterruptedException"
  "IllegalMonitorState  ArithmeticException"
  "IllegalThreadState  InterruptedException"
  "IllegalThreadState  ArithmeticException"
  "InterruptedException  ArithmeticException"
by(simp_all add: NullPointer_def ClassCast_def OutOfMemory_def ArrayIndexOutOfBounds_def ArrayStore_def NegativeArraySize_def IllegalMonitorState_def IllegalThreadState_def InterruptedException_def ArithmeticException_def)

lemmas sys_xcpts_neqs = sys_xcpts_neqs_aux sys_xcpts_neqs_aux[symmetric]

lemma Thread_neq_sys_xcpts_aux:
  "Thread  NullPointer"
  "Thread  ClassCast"
  "Thread  OutOfMemory"
  "Thread  ArrayIndexOutOfBounds"
  "Thread  ArrayStore"
  "Thread  NegativeArraySize"
  "Thread  ArithmeticException"
  "Thread  IllegalMonitorState"
  "Thread  IllegalThreadState"
  "Thread  InterruptedException"
by(simp_all add: Thread_def NullPointer_def ClassCast_def OutOfMemory_def ArrayIndexOutOfBounds_def ArrayStore_def NegativeArraySize_def IllegalMonitorState_def IllegalThreadState_def InterruptedException_def ArithmeticException_def)

lemmas Thread_neq_sys_xcpts = Thread_neq_sys_xcpts_aux Thread_neq_sys_xcpts_aux[symmetric]

subsection ‹Well-formedness for system classes and exceptions›

lemma
  assumes "wf_syscls P"
  shows wf_syscls_class_Object: "C fs ms. class P Object = Some (C,fs,ms)"
  and wf_syscls_class_Thread:  "C fs ms. class P Thread = Some (C,fs,ms)"
using assms
by(auto simp: map_of_SomeI wf_syscls_def is_class_def)

lemma [simp]:
  assumes "wf_syscls P"
  shows wf_syscls_is_class_Object: "is_class P Object"
  and wf_syscls_is_class_Thread: "is_class P Thread"
using assms by(simp_all add: is_class_def wf_syscls_class_Object wf_syscls_class_Thread)

lemma wf_syscls_xcpt_subcls_Throwable:
  " C  sys_xcpts; wf_syscls P   P  C * Throwable"
by(simp add: wf_syscls_def is_class_def class_def)

lemma wf_syscls_is_class_Throwable:
  "wf_syscls P  is_class P Throwable"
by(auto simp add: wf_syscls_def is_class_def class_def map_of_SomeI)

lemma wf_syscls_is_class_sub_Throwable:
  " wf_syscls P; P  C * Throwable   is_class P C"
by(erule subcls_is_class1)(erule wf_syscls_is_class_Throwable)

lemma wf_syscls_is_class_xcpt:
  " C  sys_xcpts; wf_syscls P   is_class P C"
by(blast intro: wf_syscls_is_class_sub_Throwable wf_syscls_xcpt_subcls_Throwable)

lemma wf_syscls_code [code]:
  "wf_syscls P 
   (C  set [Object, Throwable, Thread]. is_class P C)  (C  sys_xcpts. P  C * Throwable)"
by(simp only: wf_syscls_def) simp

end

Theory SystemClasses

(*  Title:      JinjaThreads/Common/SystemClasses.thy
    Author:     Gerwin Klein, Andreas Lochbihler

    Based on the Jinja theory Common/SystemClasses.thy by Gerwin Klein
*)

section ‹System Classes›

theory SystemClasses
imports
  Exceptions
begin

text ‹
  This theory provides definitions for the Object› class,
  and the system exceptions.

  Inline SystemClasses definition because they are polymorphic values that violate ML's value restriction.
›

text ‹
  Object has actually superclass, but we set it to the empty string for code generation.
  Any other class name (like @{term undefined}) would do as well except for code generation.
›
definition ObjectC :: "'m cdecl"
where [code_unfold]: 
  "ObjectC = 
  (Object, (STR '''',[],
    [(wait,[],Void,Native), 
     (notify,[],Void,Native),
     (notifyAll,[],Void,Native),
     (hashcode,[],Integer,Native),
     (clone,[],Class Object,Native),
     (print,[Integer],Void,Native),
     (currentThread,[],Class Thread,Native),
     (interrupted,[],Boolean,Native),
     (yield,[],Void,Native)
    ]))"

definition ThrowableC :: "'m cdecl"
where [code_unfold]: "ThrowableC  (Throwable, (Object, [], []))"

definition NullPointerC :: "'m cdecl"
where [code_unfold]: "NullPointerC  (NullPointer, (Throwable,[],[]))"

definition ClassCastC :: "'m cdecl"
where [code_unfold]: "ClassCastC  (ClassCast, (Throwable,[],[]))"

definition OutOfMemoryC :: "'m cdecl"
where [code_unfold]: "OutOfMemoryC  (OutOfMemory, (Throwable,[],[]))"

definition ArrayIndexOutOfBoundsC :: "'m cdecl"
where [code_unfold]: "ArrayIndexOutOfBoundsC  (ArrayIndexOutOfBounds, (Throwable,[],[]))"

definition ArrayStoreC :: "'m cdecl"
where [code_unfold]: "ArrayStoreC  (ArrayStore, (Throwable, [], []))"

definition NegativeArraySizeC :: "'m cdecl"
where [code_unfold]: "NegativeArraySizeC  (NegativeArraySize, (Throwable,[],[]))"

definition ArithmeticExceptionC :: "'m cdecl"
where [code_unfold]: "ArithmeticExceptionC  (ArithmeticException, (Throwable,[],[]))"

definition IllegalMonitorStateC :: "'m cdecl"
where [code_unfold]: "IllegalMonitorStateC  (IllegalMonitorState, (Throwable,[],[]))"

definition IllegalThreadStateC :: "'m cdecl"
where [code_unfold]: "IllegalThreadStateC  (IllegalThreadState, (Throwable,[],[]))"

definition InterruptedExceptionC :: "'m cdecl"
where [code_unfold]: "InterruptedExceptionC  (InterruptedException, (Throwable,[],[]))"

definition SystemClasses :: "'m cdecl list"
where [code_unfold]: 
  "SystemClasses  
  [ObjectC, ThrowableC, NullPointerC, ClassCastC, OutOfMemoryC,
   ArrayIndexOutOfBoundsC, ArrayStoreC, NegativeArraySizeC,
   ArithmeticExceptionC,
   IllegalMonitorStateC, IllegalThreadStateC, InterruptedExceptionC]"

end

Theory Heap

(*  Title:      JinjaThreads/Common/Heap.thy
    Author:     Andreas Lochbihler

    Reminiscent of the Jinja theory Common/Objects.thy
*)

section ‹An abstract heap model›

theory Heap
imports 
  Value
begin

primrec typeof :: "'addr val  ty"
where
  "typeof  Unit    = Some Void"
| "typeof  Null    = Some NT"
| "typeof (Bool b) = Some Boolean"
| "typeof (Intg i) = Some Integer"
| "typeof (Addr a) = None"

datatype addr_loc =
    CField cname vname
  | ACell nat

lemma rec_addr_loc [simp]: "rec_addr_loc = case_addr_loc"
by(auto simp add: fun_eq_iff split: addr_loc.splits)

primrec is_volatile :: "'m prog  addr_loc  bool"
where 
  "is_volatile P (ACell n) = False"
| "is_volatile P (CField D F) = volatile (snd (snd (field P D F)))"

locale heap_base =
  addr_base addr2thread_id thread_id2addr 
  for addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  +
  fixes spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
begin

fun typeof_h :: "'heap  'addr val  ty option"  ("typeof⇘_")
where
  "typeofh (Addr a) = map_option ty_of_htype (typeof_addr h a)"
| "typeofh  v = typeof v"

definition cname_of :: "'heap  'addr  cname"
where "cname_of h a = the_Class (ty_of_htype (the (typeof_addr h a)))"

definition hext :: "'heap  'heap  bool" ("_  _" [51,51] 50)
where
  "h  h'  typeof_addr h m typeof_addr h'"

context
  notes [[inductive_internals]]
begin

inductive addr_loc_type :: "'m prog  'heap  'addr  addr_loc  ty  bool"
  ("_,_  _@_ : _" [50, 50, 50, 50, 50] 51)
for P :: "'m prog" and h :: 'heap and a :: 'addr
where
  addr_loc_type_field:
  " typeof_addr h a = U; P  class_type_of U has F:T (fm) in D  
   P,h  a@CField D F : T"

| addr_loc_type_cell:
  " typeof_addr h a = Array_type T n'; n < n' 
   P,h  a@ACell n : T"

end

definition typeof_addr_loc :: "'m prog  'heap  'addr  addr_loc  ty"
where "typeof_addr_loc P h a al = (THE T. P,h  a@al : T)"

definition deterministic_heap_ops :: bool
where
  "deterministic_heap_ops 
  (h ad al v v'. heap_read h ad al v  heap_read h ad al v'  v = v') 
  (h ad al v h' h''. heap_write h ad al v h'  heap_write h ad al v h''  h' = h'') 
  (h hT h' a h'' a'. (h', a)  allocate h hT  (h'', a')  allocate h hT  h' = h''  a = a') 
  ¬ spurious_wakeups"

end

lemma typeof_lit_eq_Boolean [simp]: "(typeof v = Some Boolean) = (b. v = Bool b)"
by(cases v)(auto)

lemma typeof_lit_eq_Integer [simp]: "(typeof v = Some Integer) = (i. v = Intg i)"
by(cases v)(auto)

lemma typeof_lit_eq_NT [simp]: "(typeof v = Some NT) = (v = Null)"
by(cases v)(auto)

lemma typeof_lit_eq_Void [simp]: "typeof v = Some Void  v = Unit"
by(cases v)(auto)

lemma typeof_lit_neq_Class [simp]: "typeof v  Some (Class C)"
by(cases v) auto

lemma typeof_lit_neq_Array [simp]: "typeof v  Some (Array T)"
by(cases v) auto

lemma typeof_NoneD [simp,dest]:
  "typeof v = Some x  ¬ is_Addr v"
  by (cases v) auto

lemma typeof_lit_is_type:
  "typeof v = Some T  is_type P T"
by(cases v) auto

context heap_base begin

lemma typeof_h_eq_Boolean [simp]: "(typeofh v = Some Boolean) = (b. v = Bool b)"
by(cases v)(auto)

lemma typeof_h_eq_Integer [simp]: "(typeofh v = Some Integer) = (i. v = Intg i)"
by(cases v)(auto)

lemma typeof_h_eq_NT [simp]: "(typeofh v = Some NT) = (v = Null)"
by(cases v)(auto)


lemma hextI:
  " a C. typeof_addr h a = Class_type C  typeof_addr h' a = Class_type C;
     a T n. typeof_addr h a = Array_type T n  typeof_addr h' a = Array_type T n 
   h  h'"
unfolding hext_def 
by(rule map_leI)(case_tac v, simp_all)

lemma hext_objD:
  assumes "h  h'"
  and "typeof_addr h a = Class_type C"
  shows "typeof_addr h' a = Class_type C"
using assms unfolding hext_def by(auto dest: map_le_SomeD)

lemma hext_arrD:
  assumes "h  h'" "typeof_addr h a = Array_type T n"
  shows "typeof_addr h' a = Array_type T n"
using assms unfolding hext_def by(blast dest: map_le_SomeD)

lemma hext_refl [iff]: "h  h"
by (rule hextI) blast+

lemma hext_trans [trans]: " h  h'; h'  h''   h  h''"
unfolding hext_def by(rule map_le_trans)

lemma typeof_lit_typeof:
  "typeof v = T  typeofh v = T"
by(cases v)(simp_all)

lemma addr_loc_type_fun:
  " P,h  a@al : T; P,h  a@al : T'   T = T'"
by(auto elim!: addr_loc_type.cases dest: has_field_fun)

lemma THE_addr_loc_type:
  "P,h  a@al : T  (THE T. P,h  a@al : T) = T"
by(rule the_equality)(auto dest: addr_loc_type_fun)

lemma typeof_addr_locI [simp]:
  "P,h  a@al : T  typeof_addr_loc P h a al = T"
by(auto simp add: typeof_addr_loc_def dest: addr_loc_type_fun)

lemma deterministic_heap_opsI:
  " h ad al v v'.  heap_read h ad al v; heap_read h ad al v'   v = v';
     h ad al v h' h''.  heap_write h ad al v h'; heap_write h ad al v h''   h' = h'';
     h hT h' a h'' a'.  (h', a)  allocate h hT; (h'', a')  allocate h hT   h' = h''  a = a';
     ¬ spurious_wakeups 
   deterministic_heap_ops"
unfolding deterministic_heap_ops_def by blast

lemma deterministic_heap_ops_readD:
  " deterministic_heap_ops; heap_read h ad al v; heap_read h ad al v'   v = v'"
unfolding deterministic_heap_ops_def by blast

lemma deterministic_heap_ops_writeD:
  " deterministic_heap_ops; heap_write h ad al v h'; heap_write h ad al v h''   h' = h''"
unfolding deterministic_heap_ops_def by blast

lemma deterministic_heap_ops_allocateD:
  " deterministic_heap_ops; (h', a)  allocate h hT; (h'', a')  allocate h hT   h' = h''  a = a'"
unfolding deterministic_heap_ops_def by blast

lemma deterministic_heap_ops_no_spurious_wakeups:
  "deterministic_heap_ops  ¬ spurious_wakeups"
unfolding deterministic_heap_ops_def by blast

end

locale addr_conv =
  heap_base
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write
  +
  prog P
  for addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and P :: "'m prog"
  +
  assumes addr2thread_id_inverse: 
  " typeof_addr h a = Class_type C; P  C * Thread   thread_id2addr (addr2thread_id a) = a"
begin

lemma typeof_addr_thread_id2_addr_addr2thread_id [simp]:
  " typeof_addr h a = Class_type C; P  C * Thread   typeof_addr h (thread_id2addr (addr2thread_id a)) = Class_type C"
by(simp add: addr2thread_id_inverse)

end

locale heap =
  addr_conv
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write
    P
  for addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and P :: "'m prog"
  +
  assumes allocate_SomeD: " (h', a)  allocate h hT; is_htype P hT   typeof_addr h' a = Some hT"

  and hext_allocate: "a. (h', a)  allocate h hT  h  h'"

  and hext_heap_write:
  "heap_write h a al v h'  h  h'"

begin

lemmas hext_heap_ops = hext_allocate hext_heap_write

lemma typeof_addr_hext_mono:
  " h  h'; typeof_addr h a = hT   typeof_addr h' a = hT"
unfolding hext_def by(rule map_le_SomeD)

lemma hext_typeof_mono:
  " h  h'; typeofh v = Some T   typeofh' v = Some T"
by (cases v)(auto intro: typeof_addr_hext_mono)

lemma addr_loc_type_hext_mono:
  " P,h  a@al : T; h  h'   P,h'  a@al : T"
by(force elim!: addr_loc_type.cases intro: addr_loc_type.intros elim: typeof_addr_hext_mono dest: hext_arrD)

lemma type_of_hext_type_of: ― ‹FIXME: What's this rule good for?›
  " typeofh w = T; hext h h'   typeofh' w = T"
by(rule hext_typeof_mono)

lemma hext_None: " h  h'; typeof_addr h' a = None   typeof_addr h a = None"
by(rule ccontr)(auto dest: typeof_addr_hext_mono)

lemma map_typeof_hext_mono:
  " map typeofh vs = map Some Ts; h  h'    map typeofh' vs = map Some Ts"
apply(induct vs arbitrary: Ts)
apply(auto simp add: Cons_eq_map_conv intro: hext_typeof_mono)
done

lemma hext_typeof_addr_map_le:
  "h  h'  typeof_addr h m typeof_addr h'"
by(auto simp add: map_le_def dest: typeof_addr_hext_mono)

lemma hext_dom_typeof_addr_subset:
  "h  h'  dom (typeof_addr h)  dom (typeof_addr h')"
by (metis hext_typeof_addr_map_le map_le_implies_dom_le)

end

declare heap_base.typeof_h.simps [code]
declare heap_base.cname_of_def [code]

end

Theory Observable_Events

(*  Title:      JinjaThreads/Common/Observable_Events.thy
    Author:     Andreas Lochbihler
*)

section ‹Observable events in JinjaThreads›

theory Observable_Events
imports 
  Heap
  "../Framework/FWState"
begin

datatype ('addr,'thread_id) obs_event =
    ExternalCall 'addr mname "'addr val list" "'addr val"
  | ReadMem 'addr addr_loc "'addr val"
  | WriteMem 'addr addr_loc "'addr val"
  | NewHeapElem 'addr htype
  | ThreadStart 'thread_id
  | ThreadJoin 'thread_id
  | SyncLock 'addr
  | SyncUnlock 'addr
  | ObsInterrupt 'thread_id
  | ObsInterrupted 'thread_id

instance obs_event :: (type, type) obs_action
proof qed

type_synonym
  ('addr, 'thread_id, 'x, 'heap) Jinja_thread_action = 
    "('addr,'thread_id,'x,'heap,'addr,('addr, 'thread_id) obs_event) thread_action"

(* pretty printing for Jinja_thread_action type *)
print_translation let
    fun tr'
       [ a1, t1, x, h, a2
       , Const (@{type_syntax "obs_event"}, _) $ a3 $ t2] =
      if a1 = a2 andalso a2 = a3 andalso t1 = t2 then Syntax.const @{type_syntax "Jinja_thread_action"} $ a1 $ t1 $ x $ h
      else raise Match;
    in [(@{type_syntax "thread_action"}, K tr')]
  end
typ "('addr, 'thread_id, 'x, 'heap) Jinja_thread_action"

lemma range_ty_of_htype: "range ty_of_htype  range Class  range Array"
apply(rule subsetI)
apply(erule rangeE)
apply(rename_tac ht)
apply(case_tac ht)
apply auto
done

lemma some_choice: "(a. b. P b (a b))  (b. a. P b a)"
by metis

definition convert_RA :: "'addr released_locks  ('addr :: addr, 'thread_id) obs_event list"
where "ln. convert_RA ln = concat (map (λad. replicate (ln $ ad) (SyncLock ad)) (monitor_finfun_to_list ln))"

lemma set_convert_RA_not_New [simp]:
  "ln. NewHeapElem a CTn  set (convert_RA ln)"
by(auto simp add: convert_RA_def)

lemma set_convert_RA_not_Read [simp]:
  "ln. ReadMem ad al v  set (convert_RA ln)"
by(auto simp add: convert_RA_def)

end

Theory StartConfig

(*  Title:      JinjaThreads/Common/StartConfig.thy
    Author:     Andreas Lochbihler
*)

section ‹The initial configuration›

theory StartConfig
imports
  Exceptions
  Observable_Events
begin

definition initialization_list :: "cname list"
where
  "initialization_list = Thread # sys_xcpts_list"

context heap_base begin

definition create_initial_object :: "'heap × 'addr list × bool  cname  'heap × 'addr list × bool"
where
  "create_initial_object = 
  (λ(h, ads, b) C. 
     if b
     then let HA = allocate h (Class_type C)
          in if HA = {} then (h, ads, False)
             else let (h', a'') = SOME ha. ha  HA in (h', ads @ [a''], True)
     else (h, ads, False))"

definition start_heap_data :: "'heap × 'addr list × bool"
where
  "start_heap_data = foldl create_initial_object (empty_heap, [], True) initialization_list"

definition start_heap :: 'heap
where "start_heap = fst start_heap_data"

definition start_heap_ok :: bool
where "start_heap_ok = snd (snd (start_heap_data))"

definition start_heap_obs :: "('addr, 'thread_id) obs_event list"
where
  "start_heap_obs =
  map (λ(C, a). NewHeapElem a (Class_type C)) (zip initialization_list (fst (snd start_heap_data)))"

definition start_addrs :: "'addr list"
where "start_addrs = fst (snd start_heap_data)"

definition addr_of_sys_xcpt :: "cname  'addr"
where "addr_of_sys_xcpt C = the (map_of (zip initialization_list start_addrs) C)"

definition start_tid :: 'thread_id
where "start_tid = addr2thread_id (hd start_addrs)"

definition start_state :: "(cname  mname  ty list  ty  'm  'addr val list  'x)  'm prog  cname  mname  'addr val list  ('addr,'thread_id,'x,'heap,'addr) state"
where
  "start_state f P C M vs 
   let (D, Ts, T, m) = method P C M
   in (K$ None, ([start_tid  (f D M Ts T (the m) vs, no_wait_locks)], start_heap), Map.empty, {})"

lemma create_initial_object_simps:
  "create_initial_object (h, ads, b) C = 
   (if b 
    then let HA = allocate h (Class_type C)
         in if HA = {} then (h, ads, False)
            else let (h', a'') = SOME ha. ha  HA in (h', ads @ [a''], True)
    else (h, ads, False))"
unfolding create_initial_object_def by simp

lemma create_initial_object_False [simp]:
  "create_initial_object (h, ads, False) C = (h, ads, False)"
by(simp add: create_initial_object_simps)

lemma foldl_create_initial_object_False [simp]:
  "foldl create_initial_object (h, ads, False) Cs = (h, ads, False)"
by(induct Cs) simp_all

lemma NewHeapElem_start_heap_obs_start_addrsD:
  "NewHeapElem a CTn  set start_heap_obs  a  set start_addrs"
unfolding start_heap_obs_def start_addrs_def
by(auto dest: set_zip_rightD)

lemma shr_start_state: "shr (start_state f P C M vs) = start_heap"
by(simp add: start_state_def split_beta)

lemma start_heap_obs_not_Read: 
  "ReadMem ad al v  set start_heap_obs"
unfolding start_heap_obs_def by auto

lemma length_initialization_list_le_length_start_addrs:
  "length initialization_list  length start_addrs"
proof -
  { fix h ads xs
    have "length (fst (snd (foldl create_initial_object (h, ads, True) xs)))  length ads + length xs"
    proof(induct xs arbitrary: h ads)
      case Nil thus ?case by simp
    next
      case (Cons x xs)
      from this[of "fst (SOME ha. ha  allocate h (Class_type x))" "ads @ [snd (SOME ha. ha  allocate h (Class_type x))]"]
      show ?case by(clarsimp simp add: create_initial_object_simps split_beta)
    qed }
  from this[of empty_heap "[]" initialization_list]
  show ?thesis unfolding start_heap_def start_addrs_def start_heap_data_def by simp
qed

lemma (in -) distinct_initialization_list:
  "distinct initialization_list"
by(simp add: initialization_list_def sys_xcpts_list_def sys_xcpts_neqs Thread_neq_sys_xcpts)

lemma (in -) wf_syscls_initialization_list_is_class:
  " wf_syscls P; C  set initialization_list   is_class P C"
by(auto simp add: initialization_list_def sys_xcpts_list_def wf_syscls_is_class_xcpt)

lemma start_addrs_NewHeapElem_start_heap_obsD:
  "a  set start_addrs  CTn. NewHeapElem a CTn  set start_heap_obs"
using length_initialization_list_le_length_start_addrs
unfolding start_heap_obs_def start_addrs_def
by(force simp add: set_zip in_set_conv_nth intro: rev_image_eqI)

lemma in_set_start_addrs_conv_NewHeapElem:
  "a  set start_addrs  (CTn. NewHeapElem a CTn  set start_heap_obs)"
by(blast dest: start_addrs_NewHeapElem_start_heap_obsD intro: NewHeapElem_start_heap_obs_start_addrsD)


subsection @{term preallocated}

definition preallocated :: "'heap  bool"
where "preallocated h  C  sys_xcpts. typeof_addr h (addr_of_sys_xcpt C) = Class_type C"

lemma typeof_addr_sys_xcp: 
  " preallocated h; C  sys_xcpts   typeof_addr h (addr_of_sys_xcpt C) = Class_type C"
by(simp add: preallocated_def)

lemma typeof_sys_xcp:
  " preallocated h; C  sys_xcpts   typeofh (Addr (addr_of_sys_xcpt C)) = Class C"
by(simp add: typeof_addr_sys_xcp)

lemma addr_of_sys_xcpt_start_addr:
  " start_heap_ok; C  sys_xcpts   addr_of_sys_xcpt C  set start_addrs"
unfolding start_heap_ok_def start_heap_data_def initialization_list_def sys_xcpts_list_def 
  preallocated_def start_heap_def start_addrs_def
apply(simp split: prod.split_asm if_split_asm add: create_initial_object_simps)
apply(erule sys_xcpts_cases)
apply(simp_all add: addr_of_sys_xcpt_def start_addrs_def start_heap_data_def initialization_list_def sys_xcpts_list_def create_initial_object_simps)
done

lemma [simp]:
  assumes "preallocated h"
  shows typeof_ClassCast: "typeof_addr h (addr_of_sys_xcpt ClassCast) = Some(Class_type ClassCast)"
  and typeof_OutOfMemory: "typeof_addr h (addr_of_sys_xcpt OutOfMemory) = Some(Class_type OutOfMemory)" 
  and typeof_NullPointer: "typeof_addr h (addr_of_sys_xcpt NullPointer) = Some(Class_type NullPointer)" 
  and typeof_ArrayIndexOutOfBounds: 
  "typeof_addr h (addr_of_sys_xcpt ArrayIndexOutOfBounds) = Some(Class_type ArrayIndexOutOfBounds)" 
  and typeof_ArrayStore: "typeof_addr h (addr_of_sys_xcpt ArrayStore) = Some(Class_type ArrayStore)" 
  and typeof_NegativeArraySize: "typeof_addr h (addr_of_sys_xcpt NegativeArraySize) = Some(Class_type NegativeArraySize)" 
  and typeof_ArithmeticException: "typeof_addr h (addr_of_sys_xcpt ArithmeticException) = Some(Class_type ArithmeticException)" 
  and typeof_IllegalMonitorState: "typeof_addr h (addr_of_sys_xcpt IllegalMonitorState) = Some(Class_type IllegalMonitorState)"
  and typeof_IllegalThreadState: "typeof_addr h (addr_of_sys_xcpt IllegalThreadState) = Some(Class_type IllegalThreadState)" 
  and typeof_InterruptedException: "typeof_addr h (addr_of_sys_xcpt InterruptedException) = Some(Class_type InterruptedException)"
using assms
by(simp_all add: typeof_addr_sys_xcp)

lemma cname_of_xcp [simp]:
  " preallocated h; C  sys_xcpts   cname_of h (addr_of_sys_xcpt C) = C"
by(drule (1) typeof_addr_sys_xcp)(simp add: cname_of_def)

lemma preallocated_hext:
  " preallocated h; h  h'   preallocated h'"
by(auto simp add: preallocated_def dest: hext_objD)

end

context heap begin

lemma preallocated_heap_ops:
  assumes "preallocated h"
  shows preallocated_allocate: "a. (h', a)  allocate h hT  preallocated h'"
  and preallocated_write_field: "heap_write h a al v h'  preallocated h'"
using preallocated_hext[OF assms, of h']
by(blast intro: hext_heap_ops)+

lemma not_empty_pairE: " A  {}; a b. (a, b)  A  thesis   thesis"
by auto

lemma allocate_not_emptyI: "(h', a)  allocate h hT  allocate h hT  {}"
by auto

lemma allocate_Eps:
  " (h'', a'')  allocate h hT; (SOME ha. ha  allocate h hT) = (h', a')   (h', a')  allocate h hT"
by(drule sym)(auto intro: someI)

lemma preallocated_start_heap:
  " start_heap_ok; wf_syscls P   preallocated start_heap"
unfolding start_heap_ok_def start_heap_data_def initialization_list_def sys_xcpts_list_def 
  preallocated_def start_heap_def start_addrs_def
apply(clarsimp split: prod.split_asm if_split_asm simp add: create_initial_object_simps)
apply(erule not_empty_pairE)+
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(rotate_tac 13)
apply(frule allocate_SomeD, simp add: wf_syscls_is_class_xcpt, frule hext_allocate, rotate_tac 1)
apply(frule allocate_SomeD, simp add: wf_syscls_is_class_xcpt, frule hext_allocate, rotate_tac 1)
apply(frule allocate_SomeD, simp add: wf_syscls_is_class_xcpt, frule hext_allocate, rotate_tac 1)
apply(frule allocate_SomeD, simp add: wf_syscls_is_class_xcpt, frule hext_allocate, rotate_tac 1)
apply(frule allocate_SomeD, simp add: wf_syscls_is_class_xcpt, frule hext_allocate, rotate_tac 1)
apply(frule allocate_SomeD, simp add: wf_syscls_is_class_xcpt, frule hext_allocate, rotate_tac 1)
apply(frule allocate_SomeD, simp add: wf_syscls_is_class_xcpt, frule hext_allocate, rotate_tac 1)
apply(frule allocate_SomeD, simp add: wf_syscls_is_class_xcpt, frule hext_allocate, rotate_tac 1)
apply(frule allocate_SomeD, simp add: wf_syscls_is_class_xcpt, frule hext_allocate, rotate_tac 1)
apply(frule allocate_SomeD, simp add: wf_syscls_is_class_xcpt, frule hext_allocate, rotate_tac 1)
apply(frule allocate_SomeD, simp add: wf_syscls_is_class_xcpt, frule hext_allocate, rotate_tac 1)
apply(erule sys_xcpts_cases)
apply(simp_all add: addr_of_sys_xcpt_def initialization_list_def sys_xcpts_list_def sys_xcpts_neqs Thread_neq_sys_xcpts start_heap_data_def start_addrs_def create_initial_object_simps allocate_not_emptyI split del: if_split)
apply(assumption|erule typeof_addr_hext_mono)+
done

lemma start_tid_start_addrs:
  " wf_syscls P; start_heap_ok   thread_id2addr start_tid  set start_addrs"
unfolding start_heap_ok_def start_heap_data_def initialization_list_def sys_xcpts_list_def 
  preallocated_def start_heap_def start_addrs_def
apply(simp split: prod.split_asm if_split_asm add: create_initial_object_simps addr_of_sys_xcpt_def start_addrs_def start_tid_def start_heap_data_def initialization_list_def sys_xcpts_list_def)
apply(erule not_empty_pairE)+
apply(drule (1) allocate_Eps)
apply(rotate_tac -1)
apply(drule allocate_SomeD, simp)
apply(auto intro: addr2thread_id_inverse)
done

lemma
  assumes "wf_syscls P"
  shows dom_typeof_addr_start_heap: "set start_addrs  dom (typeof_addr start_heap)"
  and distinct_start_addrs: "distinct start_addrs"
proof -
  { fix h ads b and Cs xs :: "cname list"
    assume "set ads  dom (typeof_addr h)" and "distinct (Cs @ xs)" and "length Cs = length ads"
      and "C a. (C, a)  set (zip Cs ads)  typeof_addr h a = Class_type C"
      and "C. C  set xs  is_class P C"
    hence "set (fst (snd (foldl create_initial_object (h, ads, b) xs))) 
             dom (typeof_addr (fst (foldl create_initial_object (h, ads, b) xs)))  
           (distinct ads  distinct (fst (snd (foldl create_initial_object (h, ads, b) xs))))"
      (is "?concl xs h ads b Cs")
    proof(induct xs arbitrary: h ads b Cs)
      case Nil thus ?case by auto
    next
      case (Cons x xs)
      note ads = ‹set ads  dom (typeof_addr h)
      note dist = ‹distinct (Cs @ x # xs)
      note len = ‹length Cs = length ads
      note type = C a. (C, a)  set (zip Cs ads)  typeof_addr h a = Class_type C
      note is_class = C. C  set (x # xs)  is_class P C
      show ?case
      proof(cases "b  allocate h (Class_type x)  {}")
        case False thus ?thesis
          using ads len by(auto simp add: create_initial_object_simps zip_append1)
      next
        case [simp]: True
        obtain h' a' where h'a': "(SOME ha. ha  allocate h (Class_type x)) = (h', a')"
          by(cases "SOME ha. ha  allocate h (Class_type x)")
        with True have new_obj: "(h', a')  allocate h (Class_type x)"
          by(auto simp del: True intro: allocate_Eps)
        hence hext: "h  h'" by(rule hext_allocate)
        with ads new_obj have ads': "set ads  dom (typeof_addr h')"
          by(auto dest: typeof_addr_hext_mono[OF hext_allocate])
        moreover {
          from new_obj ads' is_class[of x]
          have "set (ads @ [a'])  dom (typeof_addr h')"
            by(auto dest: allocate_SomeD)
          moreover from dist have "distinct ((Cs @ [x]) @ xs)" by simp
          moreover have "length (Cs @ [x]) = length (ads @ [a'])" using len by simp
          moreover {
            fix C a
            assume "(C, a)  set (zip (Cs @ [x]) (ads @ [a']))"
            hence "typeof_addr h' a = Class_type C"
              using hext new_obj type[of C a] len is_class
              by(auto dest: allocate_SomeD hext_objD) }
          note type' = this
          moreover have is_class': "C. C  set xs  is_class P C" using is_class by simp
          ultimately have "?concl xs h' (ads @ [a']) True (Cs @ [x])" by(rule Cons)
          moreover have "a'  set ads"
          proof
            assume a': "a'  set ads"
            then obtain C where "(C, a')  set (zip Cs ads)" "C  set Cs"
              using len unfolding set_zip in_set_conv_nth by auto
            hence "typeof_addr h a' = Class_type C" by-(rule type)
            with hext have "typeof_addr h' a' = Class_type C" by(rule typeof_addr_hext_mono)
            moreover from new_obj is_class
            have "typeof_addr h' a' = Class_type x" by(auto dest: allocate_SomeD)
            ultimately have "C = x" by simp
            with dist C  set Cs show False by simp
          qed
          moreover note calculation }
        ultimately show ?thesis by(simp add: create_initial_object_simps new_obj h'a')
      qed
    qed }
  from this[of "[]" empty_heap "[]" initialization_list True]
    distinct_initialization_list wf_syscls_initialization_list_is_class[OF assms]
  show "set start_addrs  dom (typeof_addr start_heap)"
    and "distinct start_addrs"
    unfolding start_heap_def start_addrs_def start_heap_data_def by auto
qed

lemma NewHeapElem_start_heap_obsD:
  assumes "wf_syscls P"
  and "NewHeapElem a hT  set start_heap_obs"
  shows "typeof_addr start_heap a = hT"
proof -
  show ?thesis
  proof(cases hT)
    case (Class_type C)
    { fix h ads b xs Cs
      assume "(C, a)  set (zip (Cs @ xs) (fst (snd (foldl create_initial_object (h, ads, b) xs))))"
        and "(C, a)  set (zip Cs ads). typeof_addr h a = Class_type C"
        and "length Cs = length ads"
        and "C  set xs. is_class P C"
      hence "typeof_addr (fst (foldl create_initial_object (h, ads, b) xs)) a = Class_type C"
      proof(induct xs arbitrary: h ads b Cs)
        case Nil thus ?case by auto
      next
        case (Cons x xs)
        note inv = (C, a)  set (zip Cs ads). typeof_addr h a = Class_type C
          and Ca = (C, a)  set (zip (Cs @ x # xs) (fst (snd (foldl create_initial_object (h, ads, b) (x # xs)))))
          and len = ‹length Cs = length ads
          and is_class = C  set (x # xs). is_class P C
        show ?case
        proof(cases "b  allocate h (Class_type x)  {}")
          case False thus ?thesis
            using inv Ca len by(auto simp add: create_initial_object_simps zip_append1 split: if_split_asm)
        next
          case [simp]: True
          obtain h' a' where h'a': "(SOME ha. ha  allocate h (Class_type x)) = (h', a')"
            by(cases "SOME ha. ha  allocate h (Class_type x)")
          with True have new_obj: "(h', a')  allocate h (Class_type x)"
            by(auto simp del: True intro: allocate_Eps)
          hence hext: "h  h'" by(rule hext_allocate)

          have "(C, a)  set (zip ((Cs @ [x]) @ xs) (fst (snd (foldl create_initial_object (h', ads @ [a'], True) xs))))"
            using Ca new_obj by(simp add: create_initial_object_simps h'a')
          moreover have "(C, a)set (zip (Cs @ [x]) (ads @ [a'])).  typeof_addr h' a = Class_type C"
          proof(clarify)
            fix C a
            assume "(C, a)  set (zip (Cs @ [x]) (ads @ [a']))"
            thus "typeof_addr h' a = Class_type C"
              using inv len hext new_obj is_class by(auto dest: allocate_SomeD typeof_addr_hext_mono)
          qed
          moreover have "length (Cs @ [x]) = length (ads @ [a'])" using len by simp
          moreover have "C  set xs. is_class P C" using is_class by simp
          ultimately have "typeof_addr (fst (foldl create_initial_object (h', ads @ [a'], True) xs)) a = Class_type C"
            by(rule Cons)
          thus ?thesis using new_obj by(simp add: create_initial_object_simps h'a')
        qed
      qed }
    from this[of "[]" initialization_list empty_heap "[]" True] assms wf_syscls_initialization_list_is_class[of P] 
    show ?thesis by(auto simp add: start_heap_obs_def start_heap_data_def start_heap_def Class_type)
  next
    case Array_type thus ?thesis using assms
      by(auto simp add: start_heap_obs_def start_heap_data_def start_heap_def)
  qed
qed

end


subsection ‹Code generation›

definition pick_addr :: "('heap × 'addr) set  'heap × 'addr"
where "pick_addr HA = (SOME ha. ha  HA)"

lemma pick_addr_code [code]:
  "pick_addr (set [ha]) = ha"
by(simp add: pick_addr_def)

lemma (in heap_base) start_heap_data_code:
  "start_heap_data = 
   (let 
     (h, ads, b) = foldl 
        (λ(h, ads, b) C. 
           if b then
             let HA = allocate h (Class_type C)
             in if HA = {} then (h, ads, False)
                else let (h', a'') = pick_addr HA in (h', a'' # ads, True)
           else (h, ads, False)) 
        (empty_heap, [], True) 
        initialization_list 
    in (h, rev ads, b))"
unfolding start_heap_data_def create_initial_object_def pick_addr_def
by(rule rev_induct)(simp_all add: split_beta)

lemmas [code] =
  heap_base.start_heap_data_code
  heap_base.start_heap_def
  heap_base.start_heap_ok_def
  heap_base.start_heap_obs_def
  heap_base.start_addrs_def
  heap_base.addr_of_sys_xcpt_def
  heap_base.start_tid_def
  heap_base.start_state_def

end

Theory Conform

(*  Title:      JinjaThreads/Common/Conform.thy
    Author:     David von Oheimb, Tobias Nipkow, Andreas Lochbihler

    Based on the Jinja theory Common/Conform.thy by David von Oheimb and Tobias Nipkow
*)

section ‹Conformance Relations for Type Soundness Proofs›

theory Conform
imports
  StartConfig
begin

context heap_base begin

definition conf :: "'m prog  'heap  'addr val  ty  bool"   ("_,_  _ :≤ _"  [51,51,51,51] 50)
where "P,h  v :≤ T   T'. typeofh v = Some T'  P  T'  T"

definition lconf :: "'m prog  'heap  (vname  'addr val)  (vname  ty)  bool"   ("_,_  _ '(:≤') _" [51,51,51,51] 50)
where "P,h  l (:≤) E   V v. l V = Some v  (T. E V = Some T  P,h  v :≤ T)"

abbreviation confs :: "'m prog  'heap  'addr val list  ty list  bool" ("_,_  _ [:≤] _" [51,51,51,51] 50)
where "P,h  vs [:≤] Ts  ==  list_all2 (conf P h) vs Ts"

definition tconf :: "'m prog  'heap  'thread_id  bool" ("_,_  _ √t" [51,51,51] 50)
where "P,h  t √t  C. typeof_addr h (thread_id2addr t) = Class_type C  P  C * Thread"

end

locale heap_conf_base =
  heap_base +
  constrains addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  fixes hconf :: "'heap  bool"
  and P :: "'m prog"

sublocale heap_conf_base < prog P .

locale heap_conf = 
  heap
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write 
    P
  +
  heap_conf_base
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write 
    hconf P
  for addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and hconf :: "'heap  bool" 
  and P :: "'m prog" 
  +
  assumes hconf_empty [iff]: "hconf empty_heap"
  and typeof_addr_is_type: " typeof_addr h a = hT; hconf h   is_type P (ty_of_htype hT)"
  and hconf_allocate_mono: "a.  (h', a)  allocate h hT; hconf h; is_htype P hT   hconf h'"
  and hconf_heap_write_mono:
  "T.  heap_write h a al v h'; hconf h; P,h  a@al : T; P,h  v :≤ T   hconf h'"

locale heap_progress =
  heap_conf
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write
    hconf P
  for addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and hconf :: "'heap  bool" 
  and P :: "'m prog" 
  +
  assumes heap_read_total: " hconf h; P,h  a@al : T   v. heap_read h a al v  P,h  v :≤ T"
  and heap_write_total: " hconf h; P,h  a@al : T; P,h  v :≤ T   h'. heap_write h a al v h'"

locale heap_conf_read =
  heap_conf
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write
    hconf P
  for addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and hconf :: "'heap  bool" 
  and P :: "'m prog" 
  +
  assumes heap_read_conf: " heap_read h a al v; P,h  a@al : T; hconf h   P,h  v :≤ T"

locale heap_typesafe =
  heap_conf_read +
  heap_progress +
  constrains addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and hconf :: "'heap  bool"
  and P :: "'m prog"

context heap_conf begin

lemmas hconf_heap_ops_mono = 
  hconf_allocate_mono
  hconf_heap_write_mono

end

subsection‹Value conformance :≤›

context heap_base begin

lemma conf_Null [simp]: "P,h  Null :≤ T  =  P  NT  T"
unfolding conf_def by(simp (no_asm))

lemma typeof_conf[simp]: "typeofh v = Some T  P,h  v :≤ T"
unfolding conf_def by (cases v) auto

lemma typeof_lit_conf[simp]: "typeof v = Some T  P,h  v :≤ T"
by (rule typeof_conf[OF typeof_lit_typeof])

lemma defval_conf[simp]: "P,h  default_val T :≤ T"
unfolding conf_def by (cases T) auto

lemma conf_widen: "P,h  v :≤ T  P  T  T'  P,h  v :≤ T'"
unfolding conf_def by (cases v) (auto intro: widen_trans)

lemma conf_sys_xcpt:
  "preallocated h; C  sys_xcpts  P,h  Addr (addr_of_sys_xcpt C) :≤ Class C"
by(simp add: conf_def typeof_addr_sys_xcp)

lemma conf_NT [iff]: "P,h  v :≤ NT = (v = Null)"
by (auto simp add: conf_def)

lemma is_IntgI: "P,h  v :≤ Integer  is_Intg v"
by (unfold conf_def) auto

lemma is_BoolI: "P,h  v :≤ Boolean  is_Bool v"
by (unfold conf_def) auto

lemma is_RefI: "P,h  v :≤ T  is_refT T  is_Ref v"
by(cases v)(auto elim: is_refT.cases simp add: conf_def is_Ref_def)

lemma non_npD:
  " v  Null; P,h  v :≤ Class C; C  Object  
   a C'. v = Addr a  typeof_addr h a = Class_type C'  P  C' * C"
by(cases v)(auto simp add: conf_def widen_Class)

lemma non_npD2:
  "v  Null; P,h  v :≤ Class C 
   a hT. v = Addr a  typeof_addr h a = hT  P  class_type_of hT * C"
by(cases v)(auto simp add: conf_def widen_Class)

end

context heap begin

lemma conf_hext: " h  h'; P,h  v :≤ T   P,h'  v :≤ T"
unfolding conf_def by(cases v)(auto dest: typeof_addr_hext_mono)

lemma conf_heap_ops_mono:
  assumes "P,h  v :≤ T"
  shows conf_allocate_mono: "(h', a)  allocate h hT  P,h'  v :≤ T"
  and conf_heap_write_mono: "heap_write h a al v' h'  P,h'  v :≤ T"
using assms
by(auto intro: conf_hext dest: hext_heap_ops)

end

subsection‹Value list conformance [:≤]›

context heap_base begin

lemma confs_widens [trans]: "P,h  vs [:≤] Ts; P  Ts [≤] Ts'  P,h  vs [:≤] Ts'"
by (rule list_all2_trans)(rule conf_widen)

lemma confs_rev: "P,h  rev s [:≤] t = (P,h  s [:≤] rev t)"
by(rule list_all2_rev1)

lemma confs_conv_map:
  "P,h  vs [:≤] Ts' = (Ts. map typeofh vs = map Some Ts  P  Ts [≤] Ts')"
apply(induct vs arbitrary: Ts')
 apply simp
apply(case_tac Ts')
apply(auto simp add:conf_def)
apply(rule_tac x="T' # Ts" in exI)
apply(simp add: fun_of_def)
done

lemma confs_Cons2: "P,h  xs [:≤] y#ys = (z zs. xs = z#zs  P,h  z :≤ y  P,h  zs [:≤] ys)"
by (rule list_all2_Cons2)

end

context heap begin

lemma confs_hext: "P,h  vs [:≤] Ts  h  h'  P,h'  vs [:≤] Ts"
by (erule list_all2_mono, erule conf_hext, assumption)

end

subsection ‹Local variable conformance›

context heap_base begin

lemma lconf_upd:
  " P,h  l (:≤) E; P,h  v :≤ T; E V = Some T   P,h  l(Vv) (:≤) E"
unfolding lconf_def by auto

lemma lconf_empty [iff]: "P,h  Map.empty (:≤) E"
by(simp add:lconf_def)

lemma lconf_upd2: "P,h  l (:≤) E; P,h  v :≤ T  P,h  l(Vv) (:≤) E(VT)"
by(simp add:lconf_def)

end

context heap begin

lemma lconf_hext: " P,h  l (:≤) E; h  h'   P,h'  l (:≤) E"
unfolding lconf_def by(fast elim: conf_hext)

end

subsection ‹Thread object conformance›

context heap_base begin

lemma tconfI: " typeof_addr h (thread_id2addr t) = Class_type C; P  C * Thread   P,h  t √t"
by(simp add: tconf_def)

lemma tconfD: "P,h  t √t  C. typeof_addr h (thread_id2addr t) = Class_type C  P  C * Thread"
by(auto simp add: tconf_def)

end

context heap begin
 
lemma tconf_hext_mono: " P,h  t √t; h  h'   P,h'  t √t"
by(auto simp add: tconf_def dest: typeof_addr_hext_mono)

lemma tconf_heap_ops_mono:
  assumes "P,h  t √t"
  shows tconf_allocate_mono: "(h', a)  allocate h hT  P,h'  t √t"
  and tconf_heap_write_mono: "heap_write h a al v h'  P,h'  t √t"
using tconf_hext_mono[OF assms, of h']
by(blast intro: hext_heap_ops)+

lemma tconf_start_heap_start_tid:
  " start_heap_ok; wf_syscls P   P,start_heap  start_tid √t"
unfolding start_tid_def start_heap_def start_heap_ok_def start_heap_data_def initialization_list_def addr_of_sys_xcpt_def start_addrs_def sys_xcpts_list_def 
apply(clarsimp split: prod.split_asm simp add: create_initial_object_simps split: if_split_asm)
apply(erule not_empty_pairE)+
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule allocate_SomeD[where hT="Class_type Thread"])
 apply simp
apply(rule tconfI)
 apply(erule typeof_addr_hext_mono[OF hext_allocate])+
 apply simp
apply blast
done

lemma start_heap_write_typeable:
  assumes "WriteMem ad al v  set start_heap_obs"
  shows "T. P,start_heap  ad@al : T  P,start_heap  v :≤ T"
using assms
unfolding start_heap_obs_def start_heap_def
by clarsimp

end

subsection ‹Well-formed start state›

context heap_base begin

inductive wf_start_state :: "'m prog  cname  mname  'addr val list  bool"
for P :: "'m prog" and C :: cname and M :: mname and vs :: "'addr val list"
where
  wf_start_state:
  " P  C sees M:TsT = meth in D; start_heap_ok; P,start_heap  vs [:≤] Ts 
   wf_start_state P C M vs"

end

end

Theory ExternalCall

(*  Title:      JinjaThreads/Common/ExternalCall.thy
    Author:     Andreas Lochbihler
*)

section ‹Semantics of method calls that cannot be defined inside JinjaThreads›

theory ExternalCall
imports
  "../Framework/FWSemantics"
  Conform
begin

type_synonym
  ('addr,'thread_id,'heap) external_thread_action = "('addr, 'thread_id, cname × mname × 'addr,'heap) Jinja_thread_action"

(* pretty printing for external_thread_action type *)
print_translation let
    fun tr'
       [a1, t
       , Const (@{type_syntax "prod"}, _) $ Const (@{type_syntax "String.literal"}, _) $
           (Const (@{type_syntax "prod"}, _) $ Const (@{type_syntax "String.literal"}, _) $ a2)
       , h] =
      if a1 = a2 then Syntax.const @{type_syntax "external_thread_action"} $ a1 $ t $ h
      else raise Match;
    in [(@{type_syntax "Jinja_thread_action"}, K tr')]
  end
typ "('addr,'thread_id,'heap) external_thread_action"

subsection ‹Typing of external calls›

inductive external_WT_defs :: "cname  mname  ty list  ty  bool" ("(__'(_')) :: _" [50, 0, 0, 50] 60)
where
  "Threadstart([]) :: Void"
| "Threadjoin([]) :: Void"
| "Threadinterrupt([]) :: Void"
| "ThreadisInterrupted([]) :: Boolean"
| "Objectwait([]) :: Void"
| "Objectnotify([]) :: Void"
| "ObjectnotifyAll([]) :: Void"
| "Objectclone([]) :: Class Object"
| "Objecthashcode([]) :: Integer"
| "Objectprint([Integer]) :: Void"
| "ObjectcurrentThread([]) :: Class Thread"
| "Objectinterrupted([]) :: Boolean"
| "Objectyield([]) :: Void"

inductive_cases external_WT_defs_cases:
  "astart(vs) :: T"
  "ajoin(vs) :: T"
  "ainterrupt(vs) :: T"
  "aisInterrupted(vs) :: T"
  "await(vs) :: T"
  "anotify(vs) :: T"
  "anotifyAll(vs) :: T"
  "aclone(vs) :: T"
  "ahashcode(vs) :: T"
  "aprint(vs) :: T"
  "acurrentThread(vs) :: T"
  "ainterrupted([]) :: T"
  "ayield(vs) :: T"

inductive is_native :: "'m prog  htype  mname  bool"
  for P :: "'m prog" and hT :: htype and M :: mname
where " P  class_type_of hT sees M:TsT = Native in D; DM(Ts) :: T   is_native P hT M"

lemma is_nativeD: "is_native P hT M  Ts T D. P  class_type_of hT sees M:TsT = Native in D  DM(Ts)::T"
by(simp add: is_native.simps)

inductive (in heap_base) external_WT' :: "'m prog  'heap  'addr  mname  'addr val list  ty  bool"
  ("_,_  (__'(_')) : _" [50,0,0,0,50] 60)
for P :: "'m prog" and h :: 'heap and a :: 'addr and M :: mname and vs :: "'addr val list" and U :: ty
where 
  " typeof_addr h a = hT; map typeofh vs = map Some Ts; P  class_type_of hT sees M:Ts'U = Native in D; 
     P  Ts [≤] Ts'  
   P,h  aM(vs) : U"

context heap_base begin

lemma external_WT'_iff:
  "P,h  aM(vs) : U  
  (hT Ts Ts' D. typeof_addr h a = hT  map typeofh vs = map Some Ts  P  class_type_of hT sees M:Ts'U=Native in D  P  Ts [≤] Ts')"
by(simp add: external_WT'.simps)

end

context heap begin

lemma external_WT'_hext_mono:
  " P,h  aM(vs) : T; h  h'   P,h'  aM(vs) : T"
by(auto 5 2 simp add: external_WT'_iff dest: typeof_addr_hext_mono map_typeof_hext_mono)

end

subsection ‹Semantics of external calls›

datatype 'addr extCallRet = 
    RetVal "'addr val"
  | RetExc 'addr
  | RetStaySame

lemma rec_extCallRet [simp]: "rec_extCallRet = case_extCallRet"
by(auto simp add: fun_eq_iff split: extCallRet.split)

context heap_base begin

abbreviation RetEXC :: "cname  'addr extCallRet"
where "RetEXC C  RetExc (addr_of_sys_xcpt C)"

inductive heap_copy_loc :: "'addr  'addr  addr_loc  'heap  ('addr, 'thread_id) obs_event list  'heap  bool"
for a :: 'addr and a' :: 'addr and al :: addr_loc and h :: 'heap
where
  " heap_read h a al v; heap_write h a' al v h' 
   heap_copy_loc a a' al h ([ReadMem a al v, WriteMem a' al v]) h'"

inductive heap_copies :: "'addr  'addr  addr_loc list  'heap  ('addr, 'thread_id) obs_event list  'heap  bool"
for a :: 'addr and a' :: 'addr
where
  Nil: "heap_copies a a' [] h [] h"
| Cons:
  " heap_copy_loc a a' al h ob h'; heap_copies a a' als h' obs h'' 
   heap_copies a a' (al # als) h (ob @ obs) h''"

inductive_cases heap_copies_cases:
  "heap_copies a a' [] h ops h'"
  "heap_copies a a' (al#als) h ops h'"

text ‹
  Contrary to Sun's JVM 1.6.0\_07, cloning an interrupted thread does not yield an interrupted thread,
  because the interrupt flag is not stored inside the thread object.
  Starting a clone of a started thread with Sun JVM 1.6.0\_07 raises an illegal thread state exception,
  we just start another thread.
  The thread at @{url "http://mail.openjdk.java.net/pipermail/core-libs-dev/2010-August/004715.html"} discusses
  the general problem of thread cloning and argues against that.
  The bug report @{url "http://bugs.sun.com/bugdatabase/view_bug.do?bug_id=6968584"}
  changes the Thread class implementation
  such that \texttt{Object.clone()} can no longer be accessed for Thread and subclasses in Java 7.

  Array cells are never volatile themselves.
›

inductive heap_clone :: "'m prog  'heap  'addr  'heap  (('addr, 'thread_id) obs_event list × 'addr) option  bool"
for P :: "'m prog" and h :: 'heap and a :: 'addr 
where
  CloneFail:
  " typeof_addr h a = hT; allocate h hT = {} 
   heap_clone P h a h None"
| ObjClone:
  " typeof_addr h a = Class_type C; (h', a')  allocate h (Class_type C);
     P  C has_fields FDTs; heap_copies a a' (map (λ((F, D), Tfm). CField D F) FDTs) h' obs h'' 
   heap_clone P h a h'' (NewHeapElem a' (Class_type C) # obs, a')"
| ArrClone:
  " typeof_addr h a = Array_type T n; (h', a')  allocate h (Array_type T n); P  Object has_fields FDTs;
     heap_copies a a' (map (λ((F, D), Tfm). CField D F) FDTs @ map ACell [0..<n]) h' obs  h'' 
   heap_clone P h a h'' (NewHeapElem a' (Array_type T n) # obs, a')"

inductive red_external ::
  "'m prog  'thread_id  'heap  'addr  mname  'addr val list 
   ('addr, 'thread_id, 'heap) external_thread_action  'addr extCallRet  'heap  bool"
  and red_external_syntax :: 
  "'m prog  'thread_id  'addr  mname  'addr val list  'heap 
   ('addr, 'thread_id, 'heap) external_thread_action  'addr extCallRet  'heap  bool"
  ("_,_  ((__'(_')),/_) -_→ext ((_),/(_))" [50, 0, 0, 0, 0, 0, 0, 0, 0] 51)
for P :: "'m prog" and t :: 'thread_id and h :: 'heap and a :: 'addr
where
  "P,t  aM(vs), h -ta→ext va, h'  red_external P t h a M vs ta va h'"

| RedNewThread:
  " typeof_addr h a = Class_type C; P  C * Thread 
   P,t  astart([]), h -NewThread (addr2thread_id a) (C, run, a) h, ThreadStart (addr2thread_id a) →ext RetVal Unit, h"

| RedNewThreadFail:
  " typeof_addr h a = Class_type C; P  C * Thread 
   P,t  astart([]), h -ThreadExists (addr2thread_id a) True→ext RetEXC IllegalThreadState, h"

| RedJoin:
  " typeof_addr h a = Class_type C; P  C * Thread 
   P,t  ajoin([]), h -Join (addr2thread_id a), IsInterrupted t False, ThreadJoin (addr2thread_id a)→ext RetVal Unit, h"

| RedJoinInterrupt:
  " typeof_addr h a = Class_type C; P  C * Thread 
   P,t  ajoin([]), h -IsInterrupted t True, ClearInterrupt t, ObsInterrupted t→ext RetEXC InterruptedException, h"

    ― ‹Interruption should produce inter-thread actions (JLS 17.4.4) for the synchronizes-with order.
    They should synchronize with the inter-thread actions that determine whether a thread has been interrupted.
    Hence, interruption generates an @{term "ObsInterrupt"} action.

    Although @{term WakeUp} causes the interrupted thread to raise an @{term InterruptedException}
    independent of the interrupt status, the interrupt flag must be set with @{term "Interrupt"} 
    such that other threads observe the interrupted thread as interrupted
    while it competes for the monitor lock again.

    Interrupting a thread which has not yet been started does not set the interrupt flag 
    (tested with Sun HotSpot JVM 1.6.0\_07).›
  
| RedInterrupt:
  " typeof_addr h a = Class_type C; P  C * Thread 
   P,t  ainterrupt([]), h 
            -ThreadExists (addr2thread_id a) True, WakeUp (addr2thread_id a), 
              Interrupt (addr2thread_id a), ObsInterrupt (addr2thread_id a)→ext
            RetVal Unit, h"

| RedInterruptInexist:
  " typeof_addr h a = Class_type C; P  C * Thread 
   P,t  ainterrupt([]), h 
            -ThreadExists (addr2thread_id a) False→ext
            RetVal Unit, h"

| RedIsInterruptedTrue:
  " typeof_addr h a = Class_type C; P  C * Thread 
   P,t  aisInterrupted([]), h - IsInterrupted (addr2thread_id a) True, ObsInterrupted (addr2thread_id a)→ext
           RetVal (Bool True), h"

| RedIsInterruptedFalse:
  " typeof_addr h a = Class_type C; P  C * Thread 
   P,t  aisInterrupted([]), h -IsInterrupted (addr2thread_id a) False→ext RetVal (Bool False), h"

    ― ‹The JLS leaves unspecified whether @{term wait} first checks for the monitor state
    (whether the thread holds a lock on the monitor) or for the interrupt flag of the current thread.
    Sun Hotspot JVM 1.6.0\_07 seems to check for the monitor state first, so we do it here, too.›
| RedWaitInterrupt:
  "P,t  await([]), h -Unlocka, Locka, IsInterrupted t True, ClearInterrupt t, ObsInterrupted t →ext 
         RetEXC InterruptedException, h"

| RedWait:
  "P,t  await([]), h -Suspend a, Unlocka, Locka, ReleaseAcquirea, IsInterrupted t False, SyncUnlock a →ext 
         RetStaySame, h"

| RedWaitFail:
  "P,t  await([]), h -UnlockFaila→ext RetEXC IllegalMonitorState, h"

| RedWaitNotified:
  "P,t  await([]), h -Notified→ext RetVal Unit, h"

    ― ‹This rule does NOT check that the interrupted flag is set, but still clears it.
    The semantics will be that only the executing thread clears its interrupt.›
| RedWaitInterrupted:
  "P,t  await([]), h -WokenUp, ClearInterrupt t, ObsInterrupted t→ext RetEXC InterruptedException, h"

    ― ‹Calls to wait may decide to immediately wake up spuriously. This is 
    indistinguishable from waking up spuriously any time before being 
    notified or interrupted. Spurious wakeups are configured by the
    @{term spurious_wakeup} parameter of the @{term heap_base} locale.›
| RedWaitSpurious:
  "spurious_wakeups  
    P,t  await([]), h -Unlocka, Locka, ReleaseAcquirea, IsInterrupted t False, SyncUnlock a →ext
          RetVal Unit, h"

    ― ‹@{term notify} and @{term notifyAll} do not perform synchronization inter-thread actions
    because they only tests whether the thread holds a lock, but do not change the lock state.›

| RedNotify:
  "P,t  anotify([]), h -Notify a, Unlocka, Locka→ext RetVal Unit, h"

| RedNotifyFail:
  "P,t  anotify([]), h -UnlockFaila→ext RetEXC IllegalMonitorState, h"

| RedNotifyAll:
  "P,t  anotifyAll([]), h -NotifyAll a, Unlocka, Locka→ext RetVal Unit, h"

| RedNotifyAllFail:
  "P,t  anotifyAll([]), h -UnlockFaila→ext RetEXC IllegalMonitorState, h"

| RedClone:
  "heap_clone P h a h' (obs, a') 
     P,t  aclone([]), h -(K$ [], [], [], [], [], obs)→ext RetVal (Addr a'), h'"

| RedCloneFail:
  "heap_clone P h a h' None  P,t  aclone([]), h -ε→ext RetEXC OutOfMemory, h'"

| RedHashcode:
  "P,t  ahashcode([]), h -→ext RetVal (Intg (word_of_int (hash_addr a))), h"

| RedPrint:
  "P,t  aprint(vs), h -ExternalCall a print vs Unit→ext RetVal Unit, h"

| RedCurrentThread:
  "P,t  acurrentThread([]), h -→ext RetVal (Addr (thread_id2addr t)), h"

| RedInterruptedTrue:
  "P,t  ainterrupted([]), h -IsInterrupted t True, ClearInterrupt t, ObsInterrupted t→ext RetVal (Bool True), h"

| RedInterruptedFalse:
  "P,t  ainterrupted([]), h -IsInterrupted t False→ext RetVal (Bool False), h"

| RedYield:
  "P,t  ayield([]), h -Yield→ext RetVal Unit, h"

subsection ‹Aggressive formulation for external cals›

definition red_external_aggr :: 
  "'m prog  'thread_id  'addr  mname  'addr val list  'heap  
  (('addr, 'thread_id, 'heap) external_thread_action × 'addr extCallRet × 'heap) set"
where
  "red_external_aggr P t a M vs h =
   (if M = wait then
      let ad_t = thread_id2addr t
      in {(Unlocka, Locka, IsInterrupted t True, ClearInterrupt t, ObsInterrupted t, RetEXC InterruptedException, h),
          (Suspend a, Unlocka, Locka, ReleaseAcquirea, IsInterrupted t False, SyncUnlock a, RetStaySame, h),
          (UnlockFaila, RetEXC IllegalMonitorState, h),
          (Notified, RetVal Unit, h),
          (WokenUp, ClearInterrupt t, ObsInterrupted t, RetEXC InterruptedException, h)} 
         (if spurious_wakeups then {(Unlocka, Locka, ReleaseAcquirea, IsInterrupted t False, SyncUnlock a, RetVal Unit, h)} else {})
    else if M = notify then {(Notify a, Unlocka, Locka, RetVal Unit, h),
                             (UnlockFaila, RetEXC IllegalMonitorState, h)}
    else if M = notifyAll then {(NotifyAll a, Unlocka, Locka , RetVal Unit, h),
                                (UnlockFaila, RetEXC IllegalMonitorState, h)}
    else if M = clone then
       {((K$ [], [], [], [], [], obs), RetVal (Addr a'), h')|obs a' h'. heap_clone P h a h' (obs, a')}
        {(, RetEXC OutOfMemory, h')|h'. heap_clone P h a h' None}
    else if M = hashcode then {(, RetVal (Intg (word_of_int (hash_addr a))), h)}
    else if M = print then {(ExternalCall a M vs Unit, RetVal Unit, h)}
    else if M = currentThread then {(, RetVal (Addr (thread_id2addr t)), h)}
    else if M = interrupted then {(IsInterrupted t True, ClearInterrupt t, ObsInterrupted t, RetVal (Bool True), h),
                                  (IsInterrupted t False, RetVal (Bool False), h)}
    else if M = yield then {(Yield, RetVal Unit, h)}
    else
      let hT = the (typeof_addr h a)
      in if P  ty_of_htype hT  Class Thread then
        let t_a = addr2thread_id a 
        in if M = start then 
             {(NewThread t_a (the_Class (ty_of_htype hT), run, a) h, ThreadStart t_a, RetVal Unit, h), 
              (ThreadExists t_a True, RetEXC IllegalThreadState, h)}
           else if M = join then 
             {(Join t_a, IsInterrupted t False, ThreadJoin t_a, RetVal Unit, h),
              (IsInterrupted t True, ClearInterrupt t, ObsInterrupted t, RetEXC InterruptedException, h)}
           else if M = interrupt then 
             {(ThreadExists t_a True, WakeUp t_a, Interrupt t_a, ObsInterrupt t_a, RetVal Unit, h), 
              (ThreadExists t_a False, RetVal Unit, h)}
           else if M = isInterrupted then
             {(IsInterrupted t_a False, RetVal (Bool False), h),
              (IsInterrupted t_a True, ObsInterrupted t_a, RetVal (Bool True), h)}
         else {(, undefined)}
      else {(, undefined)})"

lemma red_external_imp_red_external_aggr:
  "P,t  aM(vs), h -ta→ext va, h'  (ta, va, h')  red_external_aggr P t a M vs h"
unfolding red_external_aggr_def
by(auto elim!: red_external.cases split del: if_split simp add: split_beta)

end

context heap begin

lemma hext_heap_copy_loc:
  "heap_copy_loc a a' al h obs h'  h  h'"
by(blast elim: heap_copy_loc.cases dest: hext_heap_ops)

lemma hext_heap_copies:
  assumes "heap_copies a a' als h obs h'"
  shows "h  h'"
using assms by induct(blast intro: hext_heap_copy_loc hext_trans)+

lemma hext_heap_clone:
  assumes "heap_clone P h a h' res"
  shows "h  h'"
using assms by(blast elim: heap_clone.cases dest: hext_heap_ops hext_heap_copies intro: hext_trans)

theorem red_external_hext: 
  assumes "P,t  aM(vs), h -ta→ext va, h'"
  shows "hext h h'"
using assms
by(cases)(blast intro: hext_heap_ops hext_heap_clone)+

lemma red_external_preserves_tconf:
  " P,t  aM(vs), h -ta→ext va, h'; P,h  t' √t   P,h'  t' √t"
by(drule red_external_hext)(rule tconf_hext_mono)

end

context heap_conf begin

lemma typeof_addr_heap_clone:
  assumes "heap_clone P h a h' (obs, a')"
  and "hconf h"
  shows "typeof_addr h' a' = typeof_addr h a"
using assms
by cases (auto dest!: allocate_SomeD hext_heap_copies dest: typeof_addr_hext_mono typeof_addr_is_type is_type_ArrayD)

end

context heap_base begin 

lemma red_ext_new_thread_heap:
  " P,t  aM(vs), h -ta→ext va, h'; NewThread t' ex h''  set tat   h'' = h'"
by(auto elim: red_external.cases simp add: ta_upd_simps)

lemma red_ext_aggr_new_thread_heap:
  " (ta, va, h')  red_external_aggr P t a M vs h; NewThread t' ex h''  set tat   h'' = h'"
by(auto simp add: red_external_aggr_def is_native.simps split_beta ta_upd_simps split: if_split_asm)

end

context addr_conv begin

lemma red_external_new_thread_exists_thread_object:
  " P,t  aM(vs), h -ta→ext va, h'; NewThread t' x h''  set tat 
   C. typeof_addr h' (thread_id2addr t') = Class_type C  P  C * Thread"
by(auto elim!: red_external.cases dest!: Array_widen simp add: ta_upd_simps)

lemma red_external_aggr_new_thread_exists_thread_object:
  " (ta, va, h')  red_external_aggr P t a M vs h; typeof_addr h a  None;
     NewThread t' x h''  set tat 
   C. typeof_addr h' (thread_id2addr t') = Class_type C  P  C * Thread"
by(auto simp add: red_external_aggr_def is_native.simps split_beta ta_upd_simps widen_Class split: if_split_asm dest!: Array_widen)

end

context heap begin

lemma red_external_aggr_hext: 
  " (ta, va, h')  red_external_aggr P t a M vs h; is_native P (the (typeof_addr h a)) M   h  h'"
apply(auto simp add: red_external_aggr_def split_beta is_native.simps elim!: external_WT_defs_cases hext_heap_clone split: if_split_asm)
apply(auto elim!: external_WT_defs.cases dest!: sees_method_decl_above intro: widen_trans simp add: class_type_of_eq split: htype.split_asm)
done

lemma red_external_aggr_preserves_tconf:
  " (ta, va, h')  red_external_aggr P t a M vs h; is_native P (the (typeof_addr h a)) M; P,h  t' √t 
   P,h'  t' √t"
by(blast dest: red_external_aggr_hext intro: tconf_hext_mono)

end

context heap_base begin

lemma red_external_Wakeup_no_Join_no_Lock_no_Interrupt:
  " P,t  aM(vs), h -ta→ext va, h'; Notified  set taw  WokenUp  set taw  
  collect_locks tal = {}  collect_cond_actions tac = {}  collect_interrupts tai = {}"
by(auto elim!: red_external.cases simp add: ta_upd_simps collect_locks_def collect_interrupts_def)

lemma red_external_aggr_Wakeup_no_Join:
  " (ta, va, h')  red_external_aggr P t a M vs h;
     Notified  set taw  WokenUp  set taw 
   collect_locks tal = {}  collect_cond_actions tac = {}  collect_interrupts tai = {}"
by(auto simp add: red_external_aggr_def split_beta ta_upd_simps collect_locks_def collect_interrupts_def split: if_split_asm)

lemma red_external_Suspend_StaySame:
  " P,t  aM(vs), h -ta→ext va, h'; Suspend w  set taw   va = RetStaySame"
by(auto elim!: red_external.cases simp add: ta_upd_simps)

lemma red_external_aggr_Suspend_StaySame:
  " (ta, va, h')  red_external_aggr P t a M vs h; Suspend w  set taw   va = RetStaySame"
by(auto simp add: red_external_aggr_def split_beta ta_upd_simps split: if_split_asm)

lemma red_external_Suspend_waitD:
  " P,t  aM(vs), h -ta→ext va, h'; Suspend w  set taw   M = wait"
by(auto elim!: red_external.cases simp add: ta_upd_simps)

lemma red_external_aggr_Suspend_waitD:
  " (ta, va, h')  red_external_aggr P t a M vs h; Suspend w  set taw   M = wait"
by(auto simp add: red_external_aggr_def split_beta ta_upd_simps split: if_split_asm)

lemma red_external_new_thread_sub_thread:
  " P,t  aM(vs), h -ta→ext va, h'; NewThread t' (C, M', a') h''  set tat 
   typeof_addr h' a' = Class_type C  P  C * Thread  M' = run"
by(auto elim!: red_external.cases simp add: widen_Class ta_upd_simps)

lemma red_external_aggr_new_thread_sub_thread:
  " (ta, va, h')  red_external_aggr P t a M vs h; typeof_addr h a  None;
     NewThread t' (C, M', a') h''  set tat 
   typeof_addr h' a' = Class_type C  P  C * Thread  M' = run"
by(auto simp add: red_external_aggr_def split_beta ta_upd_simps widen_Class split: if_split_asm dest!: Array_widen)


lemma heap_copy_loc_length:
  assumes "heap_copy_loc a a' al h obs h'"
  shows "length obs = 2"
using assms by(cases) simp

lemma heap_copies_length:
  assumes "heap_copies a a' als h obs h'"
  shows "length obs = 2 * length als"
using assms by(induct)(auto dest!: heap_copy_loc_length)

end

subsection τ›-moves›

inductive τexternal_defs :: "cname  mname  bool"
where
  "τexternal_defs Object hashcode"
| "τexternal_defs Object currentThread"

definition τexternal :: "'m prog  htype  mname  bool"
where "τexternal P hT M  (Ts Tr D. P  class_type_of hT sees M:TsTr = Native in D  τexternal_defs D M)"

context heap_base begin

definition τexternal' :: "'m prog  'heap  'addr  mname  bool"
where "τexternal' P h a M  (hT. typeof_addr h a = Some hT  τexternal P hT M)"

lemma τexternal'_red_external_heap_unchanged:
  " P,t  aM(vs), h -ta→ext va, h'; τexternal' P h a M   h' = h"
by(auto elim!: red_external.cases τexternal_defs.cases simp add: τexternal_def τexternal'_def)

lemma τexternal'_red_external_aggr_heap_unchanged:
  " (ta, va, h')  red_external_aggr P t a M vs h; τexternal' P h a M   h' = h"
by(auto elim!: τexternal_defs.cases simp add: τexternal_def τexternal'_def red_external_aggr_def)

lemma τexternal'_red_external_TA_empty:
  " P,t  aM(vs), h -ta→ext va, h'; τexternal' P h a M   ta = ε"
by(auto elim!: red_external.cases τexternal_defs.cases simp add: τexternal_def τexternal'_def)

lemma τexternal'_red_external_aggr_TA_empty:
  " (ta, va, h')  red_external_aggr P t a M vs h; τexternal' P h a M   ta = ε"
by(auto elim!: τexternal_defs.cases simp add: τexternal_def τexternal'_def red_external_aggr_def)

lemma red_external_new_thread_addr_conf:
  " P,t  aM(vs),h -ta→ext va,h'; NewThread t (C, M, a') h''  set tat 
   P,h'  Addr a :≤ Class Thread"
by(auto elim!: red_external.cases simp add: conf_def ta_upd_simps)

lemma τexternal_red_external_aggr_heap_unchanged:
  " (ta, va, h')  red_external_aggr P t a M vs h; τexternal P (the (typeof_addr h a)) M   h' = h"
by(auto elim!: τexternal_defs.cases simp add: τexternal_def red_external_aggr_def)

lemma τexternal_red_external_aggr_TA_empty:
  " (ta, va, h')  red_external_aggr P t a M vs h; τexternal P (the (typeof_addr h a)) M   ta = ε"
by(auto elim!: τexternal_defs.cases simp add: τexternal_def red_external_aggr_def)

end

subsection ‹Code generation›

code_pred 
  (modes:
    i ⇒ i ⇒ i ⇒ i ⇒ bool,
    i ⇒ i ⇒ i ⇒ o ⇒ bool,
    i ⇒ i ⇒ o ⇒ o ⇒ bool,
    o ⇒ i ⇒ o ⇒ o ⇒ bool)
  external_WT_defs 
.

code_pred
  (modes: i ⇒ i ⇒ i ⇒ bool)
  [inductify, skip_proof]
  is_native
.

declare heap_base.heap_copy_loc.intros[code_pred_intro]

code_pred
  (modes: (i ⇒ i ⇒ i ⇒ o ⇒ bool)(i ⇒ i ⇒ i ⇒ i ⇒ o ⇒ bool) ⇒ i ⇒ i ⇒ i ⇒ i ⇒ o ⇒ o ⇒ bool) 
  heap_base.heap_copy_loc
proof -
  case heap_copy_loc
  from heap_copy_loc.prems show thesis
    by(rule heap_base.heap_copy_loc.cases)(rule heap_copy_loc.that[OF refl refl refl refl refl refl])
qed

declare heap_base.heap_copies.intros [code_pred_intro]

code_pred
  (modes: (i ⇒ i ⇒ i ⇒ o ⇒ bool) => (i ⇒ i ⇒ i ⇒ i ⇒ o ⇒ bool) ⇒ i ⇒ i ⇒ i ⇒ i ⇒ o ⇒ o ⇒ bool)
  heap_base.heap_copies
proof -
  case heap_copies
  from heap_copies.prems show thesis
    by(rule heap_base.heap_copies.cases)(erule (3) heap_copies.that[OF refl refl refl refl]|assumption)+
qed

declare heap_base.heap_clone.intros [folded Predicate_Compile.contains_def, code_pred_intro]

code_pred 
  (modes: i ⇒ i ⇒ (i ⇒ i ⇒ i ⇒ o ⇒ bool)(i ⇒ i ⇒ i ⇒ i ⇒ o ⇒ bool) ⇒ i ⇒ i ⇒ i ⇒ o ⇒ o ⇒ bool)
  heap_base.heap_clone
proof -
  case heap_clone
  from heap_clone.prems show thesis
    by(rule heap_base.heap_clone.cases[folded Predicate_Compile.contains_def])(erule (3) heap_clone.that[OF refl refl refl refl refl refl refl]|assumption)+
qed

text ‹
  code\_pred in Isabelle2012 cannot handle boolean parameters as premises properly, 
  so this replacement rule explicitly tests for @{term "True"}

lemma (in heap_base) RedWaitSpurious_Code:
  "spurious_wakeups = True  
   P,t  await([]),h -Unlocka, Locka, ReleaseAcquirea, IsInterrupted t False, SyncUnlock a→ext RetVal Unit,h"
by(rule RedWaitSpurious) simp

lemmas [code_pred_intro] =
  heap_base.RedNewThread heap_base.RedNewThreadFail 
  heap_base.RedJoin heap_base.RedJoinInterrupt
  heap_base.RedInterrupt heap_base.RedInterruptInexist heap_base.RedIsInterruptedTrue heap_base.RedIsInterruptedFalse
  heap_base.RedWaitInterrupt heap_base.RedWait heap_base.RedWaitFail heap_base.RedWaitNotified heap_base.RedWaitInterrupted
declare heap_base.RedWaitSpurious_Code [code_pred_intro RedWaitSpurious]
lemmas [code_pred_intro] =
  heap_base.RedNotify heap_base.RedNotifyFail heap_base.RedNotifyAll heap_base.RedNotifyAllFail 
  heap_base.RedClone heap_base.RedCloneFail
  heap_base.RedHashcode heap_base.RedPrint heap_base.RedCurrentThread 
  heap_base.RedInterruptedTrue heap_base.RedInterruptedFalse
  heap_base.RedYield

code_pred
  (modes: i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ (i ⇒ i ⇒ i ⇒ o ⇒ bool)(i ⇒ i ⇒ i ⇒ i ⇒ o ⇒ bool) ⇒ i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ o ⇒ o ⇒ o ⇒ bool)
  heap_base.red_external
proof -
  case red_external
  from red_external.prems show ?thesis
    apply(rule heap_base.red_external.cases)
    apply(erule (4) red_external.that[OF refl refl refl refl refl refl refl refl refl refl refl refl]|assumption|erule eqTrueI)+
    done
qed

end

Theory WellForm

(*  Title:      JinjaThreads/Common/WellForm.thy
    Author:     Tobias Nipkow, Andreas Lochbihler

    Based on the Jinja theory Common/WellForm.thy by Tobias Nipkow
*)

section ‹Generic Well-formedness of programs›

theory WellForm
imports
  SystemClasses
  ExternalCall
begin

text ‹\noindent This theory defines global well-formedness conditions
for programs but does not look inside method bodies.  Hence it works
for both Jinja and JVM programs. Well-typing of expressions is defined
elsewhere (in theory WellType›).

Because JinjaThreads does not have method overloading, its policy for method
overriding is the classical one: \emph{covariant in the result type
but contravariant in the argument types.} This means the result type
of the overriding method becomes more specific, the argument types
become more general.
›

type_synonym 'm wf_mdecl_test = "'m prog  cname  'm mdecl  bool"

definition wf_fdecl :: "'m prog  fdecl  bool"
where "wf_fdecl P  λ(F,T,fm). is_type P T"

definition wf_mdecl :: "'m wf_mdecl_test  'm prog  cname  'm mdecl'  bool" where 
  "wf_mdecl wf_md P C  
  λ(M,Ts,T,m). (Tset Ts. is_type P T)  is_type P T  
    (case m of Native  CM(Ts) :: T | mb  wf_md P C (M,Ts,T,mb))"

fun wf_overriding :: "'m prog  cname  'm mdecl'  bool"
where
  "wf_overriding P D (M,Ts,T,m) =
  (D' Ts' T' m'. P  D sees M:Ts'  T' = m' in D'  P  Ts' [≤] Ts  P  T  T')"

definition wf_cdecl :: "'m wf_mdecl_test  'm prog  'm cdecl  bool"
where
  "wf_cdecl wf_md P    λ(C,(D,fs,ms)).
  (fset fs. wf_fdecl P f)  distinct_fst fs 
  (mset ms. wf_mdecl wf_md P C m) 
  distinct_fst ms 
  (C  Object 
   is_class P D  ¬ P  D * C 
   (mset ms. wf_overriding P D m)) 
  (C = Thread  (m. (run, [], Void, m)  set ms))"

definition wf_prog :: "'m wf_mdecl_test  'm prog  bool"
where 
  "wf_prog wf_md P  wf_syscls P  distinct_fst (classes P)  (c  set (classes P). wf_cdecl wf_md P c)"

lemma wf_prog_def2:
  "wf_prog wf_md P  wf_syscls P  (C rest. class P C = rest  wf_cdecl wf_md P (C, rest))  distinct_fst (classes P)"
by(cases P)(auto simp add: wf_prog_def dest: map_of_SomeD map_of_SomeI)

subsection‹Well-formedness lemmas›

lemma wf_prog_wf_syscls: "wf_prog wf_md P  wf_syscls P"
by(simp add: wf_prog_def)

lemma class_wf: 
  "class P C = Some c; wf_prog wf_md P  wf_cdecl wf_md P (C,c)"
by (cases P) (fastforce dest: map_of_SomeD simp add: wf_prog_def)

lemma [simp]:
  assumes "wf_prog wf_md P"
  shows class_Object: "C fs ms. class P Object = Some (C,fs,ms)"
  and class_Thread:  "C fs ms. class P Thread = Some (C,fs,ms)"
using wf_prog_wf_syscls[OF assms]
by(rule wf_syscls_class_Object wf_syscls_class_Thread)+

lemma [simp]:
  assumes "wf_prog wf_md P"
  shows is_class_Object: "is_class P Object"
  and is_class_Thread: "is_class P Thread"
using wf_prog_wf_syscls[OF assms] by simp_all

lemma xcpt_subcls_Throwable:
  " C  sys_xcpts; wf_prog wf_md P   P  C * Throwable"
by(simp add: wf_prog_wf_syscls wf_syscls_xcpt_subcls_Throwable)

lemma is_class_Throwable:
  "wf_prog wf_md P  is_class P Throwable"
by(rule wf_prog_wf_syscls wf_syscls_is_class_Throwable)+

lemma is_class_sub_Throwable:
  " wf_prog wf_md P; P  C * Throwable   is_class P C"
by(rule wf_syscls_is_class_sub_Throwable[OF wf_prog_wf_syscls])

lemma is_class_xcpt:
  " C  sys_xcpts; wf_prog wf_md P   is_class P C"
by(rule wf_syscls_is_class_xcpt[OF _ wf_prog_wf_syscls])

context heap_base begin
lemma wf_preallocatedE:
  assumes "wf_prog wf_md P"
  and "preallocated h"
  and "C  sys_xcpts"
  obtains "typeof_addr h (addr_of_sys_xcpt C) = Class_type C" "P  C * Throwable"
proof -
  from ‹preallocated h C  sys_xcpts› have "typeof_addr h (addr_of_sys_xcpt C) = Class_type C" 
    by(rule typeof_addr_sys_xcp)
  moreover from C  sys_xcpts› ‹wf_prog wf_md P have "P  C * Throwable" by(rule xcpt_subcls_Throwable)
  ultimately show thesis by(rule that)
qed

lemma wf_preallocatedD:
  assumes "wf_prog wf_md P"
  and "preallocated h"
  and "C  sys_xcpts"
  shows "typeof_addr h (addr_of_sys_xcpt C) = Class_type C  P  C * Throwable"
using assms
by(rule wf_preallocatedE) blast

end

lemma (in heap_conf) hconf_start_heap:
  "wf_prog wf_md P  hconf start_heap"
unfolding start_heap_def start_heap_data_def initialization_list_def sys_xcpts_list_def
using hconf_empty
by -(simp add: create_initial_object_simps del: hconf_empty, clarsimp split: prod.split elim!: not_empty_pairE simp del: hconf_empty, drule (1) allocate_Eps, drule (1) hconf_allocate_mono, simp add: is_class_xcpt)+

lemma subcls1_wfD:
  " P  C 1 D; wf_prog wf_md P   D  C  ¬ (subcls1 P)++ D C"
apply( frule tranclp.r_into_trancl[where r="subcls1 P"])
apply( drule subcls1D)
apply(clarify)
apply( drule (1) class_wf)
apply( unfold wf_cdecl_def)
apply(rule conjI)
 apply(force)
apply(unfold reflclp_tranclp[symmetric, where r="subcls1 P"])
apply(blast)
done

lemma wf_cdecl_supD: 
  "wf_cdecl wf_md P (C,D,r); C  Object  is_class P D"
(*<*)by (auto simp: wf_cdecl_def)(*>*)


lemma subcls_asym:
  " wf_prog wf_md P; (subcls1 P)++ C D   ¬ (subcls1 P)++ D C"
(*<*)
apply(erule tranclp.cases)
apply(fast dest!: subcls1_wfD )
apply(fast dest!: subcls1_wfD intro: tranclp_trans)
done
(*>*)


lemma subcls_irrefl:
  " wf_prog wf_md P; (subcls1 P)++ C D  C  D"
(*<*)
apply (erule tranclp_trans_induct)
apply  (auto dest: subcls1_wfD subcls_asym)
done
(*>*)

lemma acyclicP_def:
  "acyclicP r  (x. ¬ r^++ x x)"
  unfolding acyclic_def trancl_def
by(auto)

lemma acyclic_subcls1:
  "wf_prog wf_md P  acyclicP (subcls1 P)"
by(unfold acyclicP_def)(fast dest: subcls_irrefl)

lemma finite_conversep: "finite {(x, y). r¯¯ x y} = finite {(x, y). r x y}"
by(subst finite_converse[unfolded converse_unfold, symmetric]) simp

lemma acyclicP_wf_subcls1:
  "acyclicP (subcls1 P)  wfP ((subcls1 P)¯¯)"
unfolding wfP_def
by(rule finite_acyclic_wf)(simp_all only: finite_conversep finite_subcls1 acyclicP_converse)

lemma wf_subcls1:
  "wf_prog wf_md P  wfP ((subcls1 P)¯¯)"
by(rule acyclicP_wf_subcls1)(rule acyclic_subcls1)

lemma single_valued_subcls1:
  "wf_prog wf_md G  single_valuedp (subcls1 G)"
(*<*)
by(auto simp:wf_prog_def distinct_fst_def single_valuedp_def dest!:subcls1D)
(*>*)


lemma subcls_induct: 
  " wf_prog wf_md P; C. D. (subcls1 P)++ C D  Q D  Q C   Q C"
(*<*)
  (is "?A  PROP ?P  _")
proof -
  assume p: "PROP ?P"
  assume ?A thus ?thesis apply -
apply(drule wf_subcls1)
apply(drule wfP_trancl)
apply(simp only: tranclp_converse)
apply(erule_tac a = C in wfP_induct)
apply(rule p)
apply(auto)
done
qed
(*>*)


lemma subcls1_induct_aux:
  " is_class P C; wf_prog wf_md P; Q Object;
    C D fs ms.
     C  Object; is_class P C; class P C = Some (D,fs,ms) 
      wf_cdecl wf_md P (C,D,fs,ms)  P  C 1 D  is_class P D  Q D  Q C 
   Q C"
(*<*)
  (is "?A  ?B  ?C  PROP ?P  _")
proof -
  assume p: "PROP ?P"
  assume ?A ?B ?C thus ?thesis apply -
apply(unfold is_class_def)
apply( rule impE)
prefer 2
apply(   assumption)
prefer 2
apply(  assumption)
apply( erule thin_rl)
apply( rule subcls_induct)
apply(  assumption)
apply( rule impI)
apply( case_tac "C = Object")
apply(  fast)
apply safe
apply( frule (1) class_wf)
apply( frule (1) wf_cdecl_supD)

apply( subgoal_tac "P  C 1 a")
apply( erule_tac [2] subcls1I)
apply(  rule p)
apply (unfold is_class_def)
apply auto
done
qed
(*>*)

lemma subcls1_induct [consumes 2, case_names Object Subcls]:
  " wf_prog wf_md P; is_class P C; Q Object;
    C D. C  Object; P  C 1 D; is_class P D; Q D  Q C 
   Q C"
(*<*)
  apply (erule subcls1_induct_aux, assumption, assumption)
  apply blast
  done
(*>*)


lemma subcls_C_Object:
  " is_class P C; wf_prog wf_md P   P  C * Object"
(*<*)
apply(erule (1) subcls1_induct)
 apply( fast)
apply(erule (1) converse_rtranclp_into_rtranclp)
done
(*>*)

lemma converse_subcls_is_class:
  assumes wf: "wf_prog wf_md P"
  shows " P  C * D; is_class P C   is_class P D"
proof(induct rule: rtranclp_induct)
  assume "is_class P C"
  thus "is_class P C" .
next
  fix D E
  assume PDE: "P  D 1 E"
    and IH: "is_class P C  is_class P D"
    and iPC: "is_class P C"
  have "is_class P D" by (rule IH[OF iPC])
  with PDE obtain fsD MsD where classD: "class P D = (E, fsD, MsD)"
    by(auto simp add: is_class_def elim!: subcls1.cases)
  thus "is_class P E" using wf PDE
    by(auto elim!: subcls1.cases dest: class_wf simp: wf_cdecl_def)
qed

lemma is_class_is_subcls:
  "wf_prog m P  is_class P C = P  C * Object"
(*<*)by (fastforce simp:is_class_def
                  elim: subcls_C_Object converse_rtranclpE subcls1I
                  dest: subcls1D)
(*>*)

lemma subcls_antisym:
  "wf_prog m P; P  C * D; P  D * C  C = D"
apply(drule acyclic_subcls1)
apply(drule acyclic_impl_antisym_rtrancl)
apply(drule antisymD)
apply(unfold Transitive_Closure.rtrancl_def)
apply(auto)
done

lemma is_type_pTs:
  " wf_prog wf_md P; class P C = (S,fs,ms); (M,Ts,T,m)  set ms   set Ts  types P"
by(fastforce dest: class_wf simp add: wf_cdecl_def wf_mdecl_def)

lemma widen_asym_1: 
  assumes wfP: "wf_prog wf_md P"
  shows "P  C  D  C = D  ¬ (P  D  C)"
proof (erule widen.induct)
  fix T
  show "T = T  ¬ (P  T  T)" by simp
next
  fix C D
  assume CscD: "P  C * D"
  then have CpscD: "C = D  (C  D  (subcls1 P)++ C D)" by (simp add: rtranclpD)
  { assume "P  D * C"
    then have DpscC: "D = C  (D  C  (subcls1 P)++ D C)" by (simp add: rtranclpD)
    { assume "(subcls1 P)++ D C"
      with wfP have CnscD: "¬ (subcls1 P)++ C D" by (rule subcls_asym)
      with CpscD have "C = D" by simp
    }
    with DpscC have "C = D" by blast
  }
  hence "Class C = Class D  ¬ (P  D * C)" by blast
  thus "Class C = Class D  ¬ P  Class D  Class C" by simp
next
  fix C
  show "NT = Class C  ¬ P  Class C  NT" by simp
next
  fix A
  { assume "P  A⌊⌉  NT"
    hence "A⌊⌉ = NT" by fastforce
    hence "False" by simp }
  hence "¬ (P  A⌊⌉  NT)" by blast
  thus "NT = A⌊⌉  ¬ P  A⌊⌉  NT" by simp
next
  fix A
  show "A⌊⌉ = Class Object  ¬ P  Class Object  A⌊⌉"
    by(auto dest: Object_widen)
next
  fix A B
  assume AsU: "P  A  B" and BnpscA: "A = B  ¬ P  B  A"
  { assume "P  B⌊⌉  A⌊⌉"
    hence "P  B  A" by (auto dest: Array_Array_widen)
    with BnpscA have "A = B" by blast
    hence "A⌊⌉ = B⌊⌉" by simp }
  thus "A⌊⌉ = B⌊⌉  ¬ P  B⌊⌉  A⌊⌉" by blast
qed

lemma widen_asym: " wf_prog wf_md P; P  C  D; C  D   ¬ (P  D  C)"
proof -
  assume wfP: "wf_prog wf_md P" and CsD: "P  C  D" and CneqD: "C  D"
  from wfP CsD have "C = D  ¬ (P  D  C)" by (rule widen_asym_1)
  with CneqD show ?thesis by simp
qed

lemma widen_antisym:
  " wf_prog m P; P  T  U; P  U  T   T = U"
by(auto dest: widen_asym)

lemma widen_C_Object: " wf_prog wf_md P; is_class P C   P  Class C  Class Object"
by(simp add: subcls_C_Object)

lemma is_refType_widen_Object:
  assumes wfP: "wf_prog wfmc P"
  shows " is_type P A; is_refT A   P  A  Class Object"
by(induct A)(auto elim: refTE intro: subcls_C_Object[OF _ wfP] widen_array_object)

lemma is_lub_unique:
  assumes wf: "wf_prog wf_md P"
  shows " P  lub(U, V) = T; P  lub(U, V) = T'   T = T'"
by(auto elim!: is_lub.cases intro: widen_antisym[OF wf])

subsection‹Well-formedness and method lookup›

lemma sees_wf_mdecl:
  " wf_prog wf_md P; P  C sees M:TsT = m in D   wf_mdecl wf_md P D (M,Ts,T,m)"
(*<*)
apply(drule visible_method_exists)
apply(clarify)
apply(drule class_wf, assumption)
apply(drule map_of_SomeD)
apply(auto simp add: wf_cdecl_def)
done
(*>*)


lemma sees_method_mono [rule_format (no_asm)]: 
  " P  C' * C; wf_prog wf_md P  
  D Ts T m. P  C sees M:TsT = m in D 
     (D' Ts' T' m'. P  C' sees M:Ts'T' = m' in D'  P  Ts [≤] Ts'  P  T'  T)"
apply( drule rtranclpD)
apply( erule disjE)
apply(  fastforce intro: widen_refl widens_refl)
apply( erule conjE)
apply( erule tranclp_trans_induct)
prefer 2
apply(  clarify)
apply(  drule spec, drule spec, drule spec, drule spec, erule (1) impE)
apply clarify
apply(  fast elim: widen_trans widens_trans)
apply( clarify)
apply( drule subcls1D)
apply( clarify)
apply(clarsimp simp:Method_def)
apply(frule (2) sees_methods_rec)
apply(rule refl)
apply(case_tac "map_of ms M")
apply(rule_tac x = D in exI)
apply(rule_tac x = Ts in exI)
apply(rule_tac x = T in exI)
apply(clarsimp simp add: widens_refl)
apply(rule_tac x = m in exI)
apply(fastforce simp add:map_add_def split:option.split)
apply clarsimp
apply(rename_tac Ts' T' m')
apply( drule (1) class_wf)
apply( unfold wf_cdecl_def Method_def)
apply( frule map_of_SomeD)
apply(clarsimp)
apply(drule (1) bspec)+
apply clarsimp
apply(erule_tac x=D in allE)
apply(erule_tac x=Ts in allE)
apply(rotate_tac -1)
apply(erule_tac x=T in allE)
apply(fastforce simp:map_add_def Method_def split:option.split)
done
(*>*)

lemma sees_method_mono2:
  " P  C' * C; wf_prog wf_md P;
     P  C sees M:TsT = m in D; P  C' sees M:Ts'T' = m' in D' 
   P  Ts [≤] Ts'  P  T'  T"
(*<*)by(blast dest:sees_method_mono sees_method_fun)(*>*)


lemma mdecls_visible:
  assumes wf: "wf_prog wf_md P" and "class": "is_class P C"
  shows "D fs ms. class P C = Some(D,fs,ms)
          Mm. P  C sees_methods Mm  ((M,Ts,T,m)  set ms. Mm M = Some((Ts,T,m),C))"
using wf "class"
proof (induct rule:subcls1_induct)
  case Object
  with wf have "distinct_fst ms"
    by(auto dest: class_wf simp add: wf_cdecl_def)
  with Object show ?case by(fastforce intro!: sees_methods_Object map_of_SomeI)
next
  case Subcls
  with wf have "distinct_fst ms"
    by(auto dest: class_wf simp add: wf_cdecl_def)
  with Subcls show ?case
    by(fastforce elim:sees_methods_rec dest:subcls1D map_of_SomeI
                simp:is_class_def)
qed


lemma mdecl_visible:
  assumes wf: "wf_prog wf_md P" and C: "class P C = (S,fs,ms)" and  m: "(M,Ts,T,m)  set ms"
  shows "P  C sees M:TsT = m in C"
proof -
  from C have "is_class P C" by(auto simp:is_class_def)
  with assms show ?thesis
    by(bestsimp simp:Method_def dest:mdecls_visible)
qed

lemma sees_wf_native:
  " wf_prog wf_md P; P  C sees M:TsT=Native in D   DM(Ts) :: T"
apply(drule (1) sees_wf_mdecl)
apply(simp add: wf_mdecl_def)
done

lemma Call_lemma:
  " P  C sees M:TsT = m in D; P  C' * C; wf_prog wf_md P 
   D' Ts' T' m'.
       P  C' sees M:Ts'T' = m' in D'  P  Ts [≤] Ts'  P  T'  T  P  C' * D'
        is_type P T'  (Tset Ts'. is_type P T)  (m'  Native  wf_md P D' (M,Ts',T',the m'))"
apply(frule (2) sees_method_mono)
apply(fastforce intro:sees_method_decl_above dest:sees_wf_mdecl
               simp: wf_mdecl_def)
done

lemma sub_Thread_sees_run:
  assumes wf: "wf_prog wf_md P"
  and PCThread: "P  C * Thread"
  shows "D mthd. P  C sees run: []Void = mthd in D"
proof -
  from class_Thread[OF wf] obtain T' fsT MsT
    where classT: "class P Thread = (T', fsT, MsT)" by blast
  hence wfcThread: "wf_cdecl wf_md P (Thread, T', fsT, MsT)" using wf by(rule class_wf)
  then obtain mrunT where runThread: "(run, [], Void, mrunT)  set MsT"
    by(auto simp add: wf_cdecl_def)
  moreover have "MmT. P  Thread sees_methods MmT 
                       ((M,Ts,T,m)  set MsT. MmT M = Some((Ts,T,m),Thread))"
    by(rule mdecls_visible[OF wf is_class_Thread[OF wf] classT])
  then obtain MmT where ThreadMmT: "P  Thread sees_methods MmT"
    and MmT: "(M,Ts,T,m)  set MsT. MmT M = Some((Ts,T,m),Thread)"
    by blast
  ultimately obtain mthd
    where "MmT run = (([], Void, mthd), Thread)"
    by(fastforce)
  with ThreadMmT have Tseesrun: "P  Thread sees run: []Void = mthd in Thread"
    by(auto simp add: Method_def)
  from sees_method_mono[OF PCThread wf Tseesrun]
  obtain D' m' where "P  C sees run: []Void = m' in D'" by auto
  moreover have "m'  None"
  proof
    assume "m' = None"
    with wf P  C sees run: []Void = m' in D' have "D'run([]) :: Void"
      by(auto intro: sees_wf_native)
    thus False by cases auto
  qed
  ultimately show ?thesis by auto
qed

lemma wf_prog_lift:
  assumes wf: "wf_prog (λP C bd. A P C bd) P"
  and rule:
  "wf_md C M Ts C T m.
    wf_prog wf_md P; P  C sees M:TsT = m in C; is_class P C; set Ts  types P; A P C (M,Ts,T,m) 
    B P C (M,Ts,T,m)"
  shows "wf_prog (λP C bd. B P C bd) P"
proof(cases P)
  case (Program P')
  thus ?thesis using wf
    apply(clarsimp simp add: wf_prog_def wf_cdecl_def)
    apply(drule (1) bspec)
    apply(rename_tac C D fs ms)
    apply(subgoal_tac "is_class P C")
     prefer 2
     apply(simp add: is_class_def)
     apply(drule weak_map_of_SomeI)
     apply(simp add: Program)
    apply(clarsimp simp add: Program wf_mdecl_def split del: option.split)
    apply(drule (1) bspec)
    apply clarsimp
    apply(rule conjI)
     apply clarsimp
    apply clarsimp
    apply(frule (1) map_of_SomeI)
    apply(rule rule[OF wf, unfolded Program])
    apply(clarsimp simp add: is_class_def)
    apply(rule mdecl_visible[OF wf[unfolded Program]])
    apply(fastforce intro: is_type_pTs [OF wf, unfolded Program])+
    done
qed
    
subsection‹Well-formedness and field lookup›

lemma wf_Fields_Ex:
  " wf_prog wf_md P; is_class P C   FDTs. P  C has_fields FDTs"
(*<*)
apply(frule class_Object)
apply(erule (1) subcls1_induct)
 apply(blast intro:has_fields_Object)
apply(blast intro:has_fields_rec dest:subcls1D)
done
(*>*)


lemma has_fields_types:
  " P  C has_fields FDTs; (FD, T, fm)  set FDTs; wf_prog wf_md P   is_type P T"
(*<*)
apply(induct rule:Fields.induct)
 apply(fastforce dest!: class_wf simp: wf_cdecl_def wf_fdecl_def)
apply(fastforce dest!: class_wf simp: wf_cdecl_def wf_fdecl_def)
done
(*>*)


lemma sees_field_is_type:
  " P  C sees F:T (fm) in D; wf_prog wf_md P   is_type P T"
by(fastforce simp: sees_field_def
            elim: has_fields_types map_of_SomeD[OF map_of_remap_SomeD])

lemma wf_has_field_mono2:
  assumes wf: "wf_prog wf_md P"
  and has: "P  C has F:T (fm) in E"
  shows " P  C * D; P  D * E   P  D has F:T (fm) in E"
proof(induct rule: rtranclp_induct)
  case base show ?case using has .
next
  case (step D D')
  note DsubD' = P  D 1 D'
  from DsubD' obtain rest where classD: "class P D = (D', rest)"
    and DObj: "D  Object" by(auto elim!: subcls1.cases)
  from DsubD' P  D' * E have DsubE: "P  D * E" and DsubE2: "(subcls1 P)^++ D E"
    by(rule converse_rtranclp_into_rtranclp rtranclp_into_tranclp2)+
  from wf DsubE2 have DnE: "D  E" by(rule subcls_irrefl)
  from DsubE have hasD: "P  D has F:T (fm) in E" by(rule P  D * E  P  D has F:T (fm) in E)
  then obtain FDTs where hasf: "P  D has_fields FDTs" and FE: "map_of FDTs (F, E) = (T, fm)"
    unfolding has_field_def by blast
  from hasf show ?case
  proof cases
    case has_fields_Object with DObj show ?thesis by simp
  next
    case (has_fields_rec DD' fs ms FDTs')
    with classD have [simp]: "DD' = D'" "rest = (fs, ms)"
      and hasf': "P  D' has_fields FDTs'"
      and FDTs: "FDTs = map (λ(F, Tm). ((F, D), Tm)) fs @ FDTs'" by auto
    from FDTs FE DnE hasf' show ?thesis by(auto dest: map_of_SomeD simp add: has_field_def)
  qed
qed

lemma wf_has_field_idemp:
  " wf_prog wf_md P; P  C has F:T (fm) in D   P  D has F:T (fm) in D"
apply(frule has_field_decl_above)
apply(erule (2) wf_has_field_mono2)
apply(rule rtranclp.rtrancl_refl)
done

lemma map_of_remap_conv:
  " distinct_fst fs; map_of (map (λ(F, y). ((F, D), y)) fs) (F, D) = T 
   map_of (map (λ((F, D), T). (F, D, T)) (map (λ(F, y). ((F, D), y)) fs)) F = (D, T)"
apply(induct fs)
apply auto
done

lemma has_field_idemp_sees_field:
  assumes wf: "wf_prog wf_md P"
  and has: "P  D has F:T (fm) in D"
  shows "P  D sees F:T (fm) in D"
proof -
  from has obtain FDTs where hasf: "P  D has_fields FDTs"
    and FD: "map_of FDTs (F, D) = (T, fm)" unfolding has_field_def by blast
  from hasf have "map_of (map (λ((F, D), T). (F, D, T)) FDTs) F = (D, T, fm)"
  proof cases
    case (has_fields_Object D' fs ms)
    from ‹class P Object = (D', fs, ms) wf
    have "wf_cdecl wf_md P (Object, D', fs, ms)" by(rule class_wf)
    hence "distinct_fst fs" by(simp add: wf_cdecl_def)
    with FD has_fields_Object show ?thesis by(auto intro: map_of_remap_conv simp del: map_map)
  next
    case (has_fields_rec D' fs ms FDTs')
    hence [simp]: "FDTs = map (λ(F, Tm). ((F, D), Tm)) fs @ FDTs'"
      and classD: "class P D = (D', fs, ms)" and DnObj: "D  Object"
      and hasf': "P  D' has_fields FDTs'" by auto
    from ‹class P D = (D', fs, ms) wf
    have "wf_cdecl wf_md P (D, D', fs, ms)" by(rule class_wf)
    hence "distinct_fst fs" by(simp add: wf_cdecl_def)
    moreover have "map_of FDTs' (F, D) = None"
    proof(rule ccontr)
      assume "map_of FDTs' (F, D)  None"
      then obtain T' fm' where "map_of FDTs' (F, D) = (T', fm')" by(auto)
      with hasf' have "P  D' * D" by(auto dest!: map_of_SomeD intro: has_fields_decl_above)
      with classD DnObj have "(subcls1 P)^++ D D"
        by(auto intro: subcls1.intros rtranclp_into_tranclp2)
      with wf show False by(auto dest: subcls_irrefl)
    qed
    ultimately show ?thesis using FD hasf'
      by(auto simp add: map_add_Some_iff intro: map_of_remap_conv simp del: map_map)
  qed
  with hasf show ?thesis unfolding sees_field_def by blast
qed

lemma has_fields_distinct:
  assumes wf: "wf_prog wf_md P"
  and "P  C has_fields FDTs"
  shows "distinct (map fst FDTs)"
using P  C has_fields FDTs
proof(induct)
  case (has_fields_Object D fs ms FDTs)
  have eq: "map (fst  (λ(F, y). ((F, Object), y))) fs = map ((λF. (F, Object))  fst) fs" by(auto)
  from ‹class P Object = (D, fs, ms) wf
  have "wf_cdecl wf_md P (Object, D, fs, ms)" by(rule class_wf)
  hence "distinct (map fst fs)" by(simp add: wf_cdecl_def distinct_fst_def)
  hence "distinct (map (fst  (λ(F, y). ((F, Object), y))) fs)" 
    unfolding eq distinct_map by(auto intro: comp_inj_on inj_onI)
  thus ?case using FDTs = map (λ(F, T). ((F, Object), T)) fs by(simp)
next
  case (has_fields_rec C D fs ms FDTs FDTs')
  have eq: "map (fst  (λ(F, y). ((F, C), y))) fs = map ((λF. (F, C))  fst) fs" by(auto)
  from ‹class P C = (D, fs, ms) wf
  have "wf_cdecl wf_md P (C, D, fs, ms)" by(rule class_wf)
  hence "distinct (map fst fs)" by(simp add: wf_cdecl_def distinct_fst_def)
  hence "distinct (map (fst  (λ(F, y). ((F, C), y))) fs)"
    unfolding eq distinct_map by(auto intro: comp_inj_on inj_onI)
  moreover from ‹class P C = (D, fs, ms) C  Object›
  have "P  C 1 D" by(rule subcls1.intros)
  with P  D has_fields FDTs
  have "(fst  (λ(F, y). ((F, C), y))) ` set fs  fst ` set FDTs = {}"
    by(auto dest: subcls_notin_has_fields)
  ultimately show ?case using FDTs' = map (λ(F, T). ((F, C), T)) fs @ FDTs ‹distinct (map fst FDTs) by simp
qed


subsection ‹Code generation›

code_pred
  (modes: i ⇒ i ⇒ i ⇒ bool)
  [inductify]
  wf_overriding 
.

text ‹
  Separate subclass acycilicity from class declaration check.
  Otherwise, cyclic class hierarchies might lead to non-termination
  as @{term "Methods"} recurses over the class hierarchy.
›

definition acyclic_class_hierarchy :: "'m prog  bool"
where
  "acyclic_class_hierarchy P  
  ((C, D, fs, ml)  set (classes P). C  Object  ¬ P  D * C)"

definition wf_cdecl' :: "'m wf_mdecl_test  'm prog  'm cdecl  bool"
where
  "wf_cdecl' wf_md P = (λ(C,(D,fs,ms)).
  (fset fs. wf_fdecl P f)  distinct_fst fs 
  (mset ms. wf_mdecl wf_md P C m) 
  distinct_fst ms 
  (C  Object  is_class P D  (mset ms. wf_overriding P D m)) 
  (C = Thread  (m. (run, [], Void, m)  set ms)))"

lemma acyclic_class_hierarchy_code [code]:
  "acyclic_class_hierarchy P  ((C, D, fs, ml)  set (classes P). C  Object  ¬ subcls' P D C)"
by(simp add: acyclic_class_hierarchy_def subcls'_def)

lemma wf_cdecl'_code [code]:
  "wf_cdecl' wf_md P = (λ(C,(D,fs,ms)).
  (fset fs. wf_fdecl P f)   distinct_fst fs 
  (mset ms. wf_mdecl wf_md P C m) 
  distinct_fst ms 
  (C  Object  is_class P D  (mset ms. wf_overriding P D m)) 
  (C = Thread  ((run, [], Void)  set (map (λ(M, Ts, T, b). (M, Ts, T)) ms))))"
by(auto simp add: wf_cdecl'_def intro!: ext intro: rev_image_eqI)

declare set_append [symmetric, code_unfold]

lemma wf_prog_code [code]:
  "wf_prog wf_md P 
   acyclic_class_hierarchy P 
   wf_syscls P  distinct_fst (classes P) 
   (c  set (classes P). wf_cdecl' wf_md P c)"
unfolding wf_prog_def wf_cdecl_def wf_cdecl'_def acyclic_class_hierarchy_def split_def
by blast

end

Theory ExternalCallWF

(*  Title:      JinjaThreads/Common/ExternalCallWF.thy
    Author:     Andreas Lochbihler
*)

section ‹Properties of external calls in well-formed programs›

theory ExternalCallWF
imports
  WellForm
  "../Framework/FWSemantics"
begin

lemma external_WT_defs_is_type:
  assumes "wf_prog wf_md P" and "CM(Ts) :: T"
  shows "is_class P C" and "is_type P T" "set Ts  types P"
using assms by(auto elim: external_WT_defs.cases)

context heap_base begin

lemma WT_red_external_aggr_imp_red_external:
  " wf_prog wf_md P; (ta, va, h')  red_external_aggr P t a M vs h; P,h  aM(vs) : U; P,h  t √t 
   P,t  aM(vs), h -ta→ext va, h'"
apply(drule tconfD)
apply(erule external_WT'.cases)
apply(clarsimp)
apply(drule (1) sees_wf_native)
apply(erule external_WT_defs.cases)
apply(case_tac [!] hT)
apply(auto 4 4 simp add: red_external_aggr_def widen_Class intro: red_external.intros heap_base.red_external.intros[where addr2thread_id=addr2thread_id and thread_id2addr=thread_id2addr and spurious_wakeups=True and empty_heap=empty_heap and allocate=allocate and typeof_addr=typeof_addr and heap_read=heap_read and heap_write=heap_write] heap_base.red_external.intros[where addr2thread_id=addr2thread_id and thread_id2addr=thread_id2addr and spurious_wakeups=False and empty_heap=empty_heap and allocate=allocate and typeof_addr=typeof_addr and heap_read=heap_read and heap_write=heap_write] split: if_split_asm dest: sees_method_decl_above)
done

lemma WT_red_external_list_conv:
  " wf_prog wf_md P; P,h  aM(vs) : U; P,h  t √t 
   P,t  aM(vs), h -ta→ext va, h'  (ta, va, h')  red_external_aggr P t a M vs h"
by(blast intro: WT_red_external_aggr_imp_red_external red_external_imp_red_external_aggr)

lemma red_external_new_thread_sees:
  " wf_prog wf_md P; P,t  aM(vs), h -ta→ext va, h'; NewThread t' (C, M', a') h''  set tat 
   typeof_addr h' a' = Class_type C  (T meth D. P  C sees M':[]T = meth in D)"
by(fastforce elim!: red_external.cases simp add: widen_Class ta_upd_simps dest: sub_Thread_sees_run)

end

subsection ‹Preservation of heap conformance›

context heap_conf_read begin

lemma hconf_heap_copy_loc_mono:
  assumes "heap_copy_loc a a' al h obs h'"
  and "hconf h"
  and "P,h  a@al : T" "P,h  a'@al : T"
  shows "hconf h'"
proof -
  from ‹heap_copy_loc a a' al h obs h' obtain v
    where read: "heap_read h a al v"
    and "write": "heap_write h a' al v h'" by cases auto
  from read P,h  a@al : T hconf h have "P,h  v :≤ T"
    by(rule heap_read_conf)
  with "write" hconf h P,h  a'@al : T show ?thesis
    by(rule hconf_heap_write_mono)
qed

lemma hconf_heap_copies_mono:
  assumes "heap_copies a a' als h obs h'"
  and "hconf h"
  and "list_all2 (λal T. P,h  a@al : T) als Ts"
  and "list_all2 (λal T. P,h  a'@al : T) als Ts"
  shows "hconf h'"
using assms
proof(induct arbitrary: Ts)
  case Nil thus ?case by simp
next
  case (Cons al h ob h' als obs h'')
  note step = ‹heap_copy_loc a a' al h ob h'
  from ‹list_all2 (λal T. P,h  a@al : T) (al # als) Ts
  obtain T Ts' where [simp]: "Ts = T # Ts'"
    and "P,h  a@al : T" "list_all2 (λal T. P,h  a@al : T) als Ts'"
    by(auto simp add: list_all2_Cons1)
  from ‹list_all2 (λal T. P,h  a'@al : T) (al # als) Ts
  have "P,h  a'@al : T" "list_all2 (λal T. P,h  a'@al : T) als Ts'" by simp_all
  from step hconf h P,h  a@al : T P,h  a'@al : T
  have "hconf h'" by(rule hconf_heap_copy_loc_mono)
  moreover from step have "h  h'" by(rule hext_heap_copy_loc)
  from ‹list_all2 (λal T. P,h  a@al : T) als Ts'
  have "list_all2 (λal T. P,h'  a@al : T) als Ts'"
    by(rule list_all2_mono)(rule addr_loc_type_hext_mono[OF _ h  h'])
  moreover from ‹list_all2 (λal T. P,h  a'@al : T) als Ts'
  have "list_all2 (λal T. P,h'  a'@al : T) als Ts'"
    by(rule list_all2_mono)(rule addr_loc_type_hext_mono[OF _ h  h'])
  ultimately show ?case by(rule Cons)
qed

lemma hconf_heap_clone_mono:
  assumes "heap_clone P h a h' res"
  and "hconf h"
  shows "hconf h'"
using ‹heap_clone P h a h' res
proof cases
  case CloneFail thus ?thesis using hconf h
    by(fastforce intro: hconf_heap_ops_mono dest: typeof_addr_is_type)
next
  case (ObjClone C h'' a' FDTs obs)
  note FDTs = P  C has_fields FDTs
  let ?als = "map (λ((F, D), Tfm). CField D F) FDTs"
  let ?Ts = "map (λ(FD, T). fst (the (map_of FDTs FD))) FDTs"
  note ‹heap_copies a a' ?als h'' obs h'
  moreover from typeof_addr h a = Class_type C hconf h have "is_class P C"
    by(auto dest: typeof_addr_is_type)
  from (h'', a')  allocate h (Class_type C) have "h  h''" "hconf h''"
    by(rule hext_heap_ops hconf_allocate_mono)+(simp_all add: hconf h ‹is_class P C)
  note hconf h''
  moreover
  from typeof_addr h a = Class_type C FDTs
  have "list_all2 (λal T. P,h  a@al : T) ?als ?Ts"
    unfolding list_all2_map1 list_all2_map2 list_all2_refl_conv
    by(fastforce intro: addr_loc_type.intros simp add: has_field_def dest: weak_map_of_SomeI)
  hence "list_all2 (λal T. P,h''  a@al : T) ?als ?Ts"
    by(rule list_all2_mono)(rule addr_loc_type_hext_mono[OF _ h  h''])
  moreover from (h'', a')  allocate h (Class_type C) ‹is_class P C
  have "typeof_addr h'' a' = Class_type C" by(auto dest: allocate_SomeD)
  with FDTs have "list_all2 (λal T. P,h''  a'@al : T) ?als ?Ts"
    unfolding list_all2_map1 list_all2_map2 list_all2_refl_conv
    by(fastforce intro: addr_loc_type.intros simp add: has_field_def dest: weak_map_of_SomeI)
  ultimately have "hconf h'" by(rule hconf_heap_copies_mono)
  thus ?thesis using ObjClone by simp
next
  case (ArrClone T n h'' a' FDTs obs)
  let ?als = "map (λ((F, D), Tfm). CField D F) FDTs @ map ACell [0..<n]"
  let ?Ts = "map (λ(FD, T). fst (the (map_of FDTs FD))) FDTs @ replicate n T"
  note ‹heap_copies a a' ?als h'' obs h'
  moreover from typeof_addr h a = Array_type T n hconf h have "is_type P (T⌊⌉)"
    by(auto dest: typeof_addr_is_type)
  from (h'', a')  allocate h (Array_type T n) have "h  h''" "hconf h''"
    by(rule hext_heap_ops hconf_allocate_mono)+(simp_all add: hconf h ‹is_type P (T⌊⌉)[simplified])
  note hconf h''
  moreover from h  h'' typeof_addr h a = Array_type T n
  have type'a: "typeof_addr h'' a = Array_type T n" by(auto intro: hext_arrD)
  note FDTs = P  Object has_fields FDTs
  from type'a FDTs have "list_all2 (λal T. P,h''  a@al : T) ?als ?Ts"
    by(fastforce intro: list_all2_all_nthI addr_loc_type.intros simp add: has_field_def distinct_fst_def list_all2_append list_all2_map1 list_all2_map2 list_all2_refl_conv dest: weak_map_of_SomeI)
  moreover from (h'', a')  allocate h (Array_type T n) ‹is_type P (T⌊⌉)
  have "typeof_addr h'' a' = Array_type T n" by(auto dest: allocate_SomeD)
  hence "list_all2 (λal T. P,h''  a'@al : T) ?als ?Ts" using FDTs
    by(fastforce intro: list_all2_all_nthI addr_loc_type.intros simp add: has_field_def distinct_fst_def list_all2_append list_all2_map1 list_all2_map2 list_all2_refl_conv dest: weak_map_of_SomeI)
  ultimately have "hconf h'" by(rule hconf_heap_copies_mono)
  thus ?thesis using ArrClone by simp
qed

theorem external_call_hconf:
  assumes major: "P,t  aM(vs), h -ta→ext va, h'"
  and minor: "P,h  aM(vs) : U" "hconf h"
  shows "hconf h'"
using major minor
by cases(fastforce intro: hconf_heap_clone_mono)+

end

context heap_base begin

primrec conf_extRet :: "'m prog  'heap  'addr extCallRet  ty  bool" where
  "conf_extRet P h (RetVal v) T = (P,h  v :≤ T)"
| "conf_extRet P h (RetExc a) T = (P,h  Addr a :≤ Class Throwable)"
| "conf_extRet P h RetStaySame T = True"

end

context heap_conf begin

lemma red_external_conf_extRet:
  assumes wf: "wf_prog wf_md P"
  shows "P,t  aM(vs), h -ta→ext va, h'; P,h  aM(vs) : U; hconf h; preallocated h; P,h  t √t 
   conf_extRet P h' va U"
using wf apply -
apply(frule red_external_hext)
apply(drule (1) preallocated_hext)
apply(auto elim!: red_external.cases external_WT'.cases external_WT_defs_cases dest!: sees_wf_native[OF wf])
apply(auto simp add: conf_def tconf_def intro: xcpt_subcls_Throwable dest!: hext_heap_write)
apply(case_tac hT)
apply(auto 4 4 dest!: typeof_addr_heap_clone dest: typeof_addr_is_type intro: widen_array_object subcls_C_Object)
done

end

subsection ‹Progress theorems for external calls›

context heap_progress begin

lemma heap_copy_loc_progress:
  assumes hconf: "hconf h"
  and alconfa: "P,h  a@al : T"
  and alconfa': "P,h  a'@al : T"
  shows "v h'. heap_copy_loc a a' al h ([ReadMem a al v, WriteMem a' al v]) h'  P,h  v :≤ T  hconf h'"
proof -
  from heap_read_total[OF hconf alconfa]
  obtain v where "heap_read h a al v" "P,h  v :≤ T" by blast
  moreover from heap_write_total[OF hconf alconfa' P,h  v :≤ T] obtain h' where "heap_write h a' al v h'" ..
  moreover hence "hconf h'" using hconf alconfa' P,h  v :≤ T by(rule hconf_heap_write_mono)
  ultimately show ?thesis by(blast intro: heap_copy_loc.intros)
qed

lemma heap_copies_progress:
  assumes "hconf h"
  and "list_all2 (λal T. P,h  a@al : T) als Ts"
  and "list_all2 (λal T. P,h  a'@al : T) als Ts"
  shows "vs h'. heap_copies a a' als h (concat (map (λ(al, v). [ReadMem a al v, WriteMem a' al v]) (zip als vs))) h'  hconf h'"
using assms
proof(induct als arbitrary: h Ts)
  case Nil thus ?case by(auto intro: heap_copies.Nil)
next
  case (Cons al als)
  from ‹list_all2 (λal T. P,h  a@al : T) (al # als) Ts
  obtain T' Ts' where [simp]: "Ts = T' # Ts'"
    and "P,h  a@al : T'" "list_all2 (λal T. P,h  a@al : T) als Ts'"
    by(auto simp add: list_all2_Cons1)
  from ‹list_all2 (λal T. P,h  a'@al : T) (al # als) Ts
  have "P,h  a'@al : T'" and "list_all2 (λal T. P,h  a'@al : T) als Ts'" by simp_all
  from hconf h P,h  a@al : T' P,h  a'@al : T'
  obtain v h' where "heap_copy_loc a a' al h [ReadMem a al v, WriteMem a' al v] h'"
    and "hconf h'" by(fastforce dest: heap_copy_loc_progress)
  moreover hence "h  h'" by-(rule hext_heap_copy_loc)
  {
    note hconf h'
    moreover from ‹list_all2 (λal T. P,h  a@al : T) als Ts'
    have "list_all2 (λal T. P,h'  a@al : T) als Ts'"
      by(rule list_all2_mono)(rule addr_loc_type_hext_mono[OF _ h  h'])
    moreover from ‹list_all2 (λal T. P,h  a'@al : T) als Ts'
    have "list_all2 (λal T. P,h'  a'@al : T) als Ts'"
      by(rule list_all2_mono)(rule addr_loc_type_hext_mono[OF _ h  h'])
    ultimately have "vs h''. heap_copies a a' als h' (concat (map (λ(al, v). [ReadMem a al v, WriteMem a' al v]) (zip als vs))) h''  hconf h''"
      by(rule Cons) }
  then obtain vs h''
    where "heap_copies a a' als h' (concat (map (λ(al, v). [ReadMem a al v, WriteMem a' al v]) (zip als vs))) h''"
    and "hconf h''" by blast
  ultimately
  have "heap_copies a a' (al # als) h ([ReadMem a al v, WriteMem a' al v] @ (concat (map (λ(al, v). [ReadMem a al v, WriteMem a' al v]) (zip als vs)))) h''"
    by- (rule heap_copies.Cons)
  also have "[ReadMem a al v, WriteMem a' al v] @ (concat (map (λ(al, v). [ReadMem a al v, WriteMem a' al v]) (zip als vs))) =
            (concat (map (λ(al, v). [ReadMem a al v, WriteMem a' al v]) (zip (al # als) (v # vs))))" by simp
  finally show ?case using hconf h'' by blast
qed

lemma heap_clone_progress:
  assumes wf: "wf_prog wf_md P"
  and typea: "typeof_addr h a = hT"
  and hconf: "hconf h"
  shows "h' res. heap_clone P h a h' res"
proof -
  from typea hconf have "is_htype P hT" by(rule typeof_addr_is_type)
  show ?thesis
  proof(cases "allocate h hT = {}")
    case True
    with typea CloneFail[of h a hT P]
    show ?thesis by auto
  next
    case False
    then obtain h' a' where new: "(h', a')  allocate h hT" by(rule not_empty_pairE)
    hence "h  h'" by(rule hext_allocate)
    have "hconf h'" using new hconf ‹is_htype P hT by(rule hconf_allocate_mono)
    show ?thesis
    proof(cases hT)
      case [simp]: (Class_type C)
      from ‹is_htype P hT have "is_class P C" by simp
      from wf_Fields_Ex[OF wf this]
      obtain FDTs where FDTs: "P  C has_fields FDTs" ..
      let ?als = "map (λ((F, D), Tfm). CField D F) FDTs"
      let ?Ts = "map (λ(FD, T). fst (the (map_of FDTs FD))) FDTs"
      from typea FDTs have "list_all2 (λal T. P,h  a@al : T) ?als ?Ts"
        unfolding list_all2_map1 list_all2_map2 list_all2_refl_conv
        by(fastforce intro: addr_loc_type.intros simp add: has_field_def dest: weak_map_of_SomeI)
      hence "list_all2 (λal T. P,h'  a@al : T) ?als ?Ts"
        by(rule list_all2_mono)(simp add: addr_loc_type_hext_mono[OF _ h  h'] split_def)
      moreover from new ‹is_class P C
      have "typeof_addr h' a' = Class_type C" by(auto dest: allocate_SomeD)
      with FDTs have "list_all2 (λal T. P,h'  a'@al : T) ?als ?Ts"
        unfolding list_all2_map1 list_all2_map2 list_all2_refl_conv
        by(fastforce intro: addr_loc_type.intros map_of_SomeI simp add: has_field_def dest: weak_map_of_SomeI)
      ultimately obtain obs h'' where "heap_copies a a' ?als h' obs h''" "hconf h''"
        by(blast dest: heap_copies_progress[OF hconf h'])
      with typea new FDTs ObjClone[of h a C h' a' P FDTs obs h'']
      show ?thesis by auto
    next
      case [simp]: (Array_type T n)
      from wf obtain FDTs where FDTs: "P  Object has_fields FDTs"
        by(blast dest: wf_Fields_Ex is_class_Object)
      let ?als = "map (λ((F, D), Tfm). CField D F) FDTs @ map ACell [0..<n]"
      let ?Ts = "map (λ(FD, T). fst (the (map_of FDTs FD))) FDTs @ replicate n T"
      from h  h' typea have type'a: "typeof_addr h' a = Array_type T n"
        by(auto intro: hext_arrD)
      from type'a FDTs have "list_all2 (λal T. P,h'  a@al : T) ?als ?Ts"
        by(fastforce intro: list_all2_all_nthI addr_loc_type.intros simp add: has_field_def list_all2_append list_all2_map1 list_all2_map2 list_all2_refl_conv dest: weak_map_of_SomeI)
      moreover from new ‹is_htype P hT
      have "typeof_addr h' a' = Array_type T n"
        by(auto dest: allocate_SomeD)
      hence "list_all2 (λal T. P,h'  a'@al : T) ?als ?Ts" using FDTs
        by(fastforce intro: list_all2_all_nthI addr_loc_type.intros simp add: has_field_def list_all2_append list_all2_map1 list_all2_map2 list_all2_refl_conv dest: weak_map_of_SomeI)
      ultimately obtain obs h'' where "heap_copies a a' ?als h' obs h''" "hconf h''"
        by(blast dest: heap_copies_progress[OF hconf h'])
      with typea new FDTs ArrClone[of h a T n h' a' P FDTs obs h'']
      show ?thesis by auto
    qed
  qed
qed

theorem external_call_progress:
  assumes wf: "wf_prog wf_md P"
  and wt: "P,h  aM(vs) : U"
  and hconf: "hconf h"
  shows "ta va h'. P,t  aM(vs), h -ta→ext va, h'"
proof -
  note [simp del] = split_paired_Ex
  from wt obtain hT Ts Ts' D
    where T: "typeof_addr h a = hT" and Ts: "map typeofh vs = map Some Ts"
    and "P  class_type_of hT sees M:Ts'U = Native in D" and subTs: "P  Ts [≤] Ts'"
    unfolding external_WT'_iff by blast
  from wf P  class_type_of hT sees M:Ts'U = Native in D
  have "DM(Ts') :: U" by(rule sees_wf_native)
  moreover from P  class_type_of hT sees M:Ts'U = Native in D
  have "P  ty_of_htype hT  Class D"
    by(cases hT)(auto dest: sees_method_decl_above intro: widen_trans widen_array_object)
  ultimately show ?thesis using T Ts subTs
  proof cases
    assume [simp]: "D = Object" "M = clone" "Ts' = []" "U = Class Object"
    from heap_clone_progress[OF wf T hconf] obtain h' res where "heap_clone P h a h' res" by blast
    thus ?thesis using subTs Ts by(cases res)(auto intro: red_external.intros)
  qed(auto simp add: widen_Class intro: red_external.intros)
qed

end

subsection ‹Lemmas for preservation of deadlocked threads›

context heap_progress begin

lemma red_external_wt_hconf_hext:
  assumes wf: "wf_prog wf_md P"
  and red: "P,t  aM(vs),h -ta→ext va,h'"
  and hext: "h''  h"
  and wt: "P,h''  aM(vs) : U"
  and tconf: "P,h''  t √t"
  and hconf: "hconf h''"
  shows "ta' va' h'''. P,t  aM(vs),h'' -ta'→ext va', h''' 
                        collect_locks tal = collect_locks ta'l 
                        collect_cond_actions tac = collect_cond_actions ta'c 
                        collect_interrupts tai = collect_interrupts ta'i"
using red wt hext
proof cases
  case (RedClone obs a')
  from wt obtain hT C Ts Ts' D
    where T: "typeof_addr h'' a = hT"
    unfolding external_WT'_iff by blast
  from heap_clone_progress[OF wf T hconf]
  obtain h''' res where "heap_clone P h'' a h''' res" by blast
  thus ?thesis using RedClone
    by(cases res)(fastforce intro: red_external.intros)+
next
  case RedCloneFail
  from wt obtain hT Ts Ts'
    where T: "typeof_addr h'' a = hT"
    unfolding external_WT'_iff by blast
  from heap_clone_progress[OF wf T hconf]
  obtain h''' res where "heap_clone P h'' a h''' res" by blast
  thus ?thesis using RedCloneFail
    by(cases res)(fastforce intro: red_external.intros)+
qed(fastforce simp add: ta_upd_simps elim!: external_WT'.cases intro: red_external.intros[simplified] dest: typeof_addr_hext_mono)+

lemma red_external_wf_red:
  assumes wf: "wf_prog wf_md P"
  and red: "P,t  aM(vs), h -ta→ext va, h'"
  and tconf: "P,h  t √t"
  and hconf: "hconf h"
  and wst: "wset s t = None  (M = wait  (w. wset s t = PostWS w))"
  obtains ta' va' h''
  where "P,t  aM(vs), h -ta'→ext va', h''"
  and "final_thread.actions_ok final s t ta'  final_thread.actions_ok' s t ta'  final_thread.actions_subset ta' ta"
proof(atomize_elim)
  let ?a_t = "thread_id2addr t"
  let ?t_a = "addr2thread_id a"

  from tconf obtain C where ht: "typeof_addr h ?a_t = Class_type C"
    and sub: "P  C * Thread" by(fastforce dest: tconfD)

  show "ta' va' h'. P,t  aM(vs), h -ta'→ext va', h'  (final_thread.actions_ok final s t ta'  final_thread.actions_ok' s t ta'  final_thread.actions_subset ta' ta)"
  proof(cases "final_thread.actions_ok' s t ta")
    case True
    have "final_thread.actions_subset ta ta" by(rule final_thread.actions_subset_refl)
    with True red show ?thesis by blast
  next
    case False
    note [simp] = final_thread.actions_ok'_iff lock_ok_las'_def final_thread.cond_action_oks'_subset_Join
      final_thread.actions_subset_iff ta_upd_simps collect_cond_actions_def collect_interrupts_def
    note [rule del] = subsetI
    note [intro] = collect_locks'_subset_collect_locks red_external.intros[simplified]

    show ?thesis
    proof(cases "wset s t")
      case [simp]: (Some w)
      with wst obtain w' where [simp]: "w = PostWS w'" "M = wait" by auto
      from red have [simp]: "vs = []" by(auto elim: red_external.cases)
      show ?thesis
      proof(cases w')
        case [simp]: WSWokenUp
        let ?ta' = "WokenUp, ClearInterrupt t, ObsInterrupted t"
        have "final_thread.actions_ok' s t ?ta'" by(simp add: wset_actions_ok_def)
        moreover have "final_thread.actions_subset ?ta' ta"
          by(auto simp add: collect_locks'_def finfun_upd_apply)
        moreover from RedWaitInterrupted
        have "va h'. P,t  aM(vs),h -?ta'→ext va,h'" by auto
        ultimately show ?thesis by blast
      next
        case [simp]: WSNotified
        let ?ta' = "Notified"
        have "final_thread.actions_ok' s t ?ta'" by(simp add: wset_actions_ok_def)
        moreover have "final_thread.actions_subset ?ta' ta"
          by(auto simp add: collect_locks'_def finfun_upd_apply)
        moreover from RedWaitNotified
        have "va h'. P,t  aM(vs),h -?ta'→ext va,h'" by auto
        ultimately show ?thesis by blast
      qed
    next
      case None

      from red False show ?thesis
      proof cases
        case (RedNewThread C)
        note ta = ta = NewThread ?t_a (C, run, a) h, ThreadStart ?t_a
        let ?ta' = "ThreadExists ?t_a True"
        from ta False None have "final_thread.actions_ok' s t ?ta'" by(auto)
        moreover from ta have "final_thread.actions_subset ?ta' ta" by(auto)
        ultimately show ?thesis using RedNewThread by(fastforce)
      next
        case RedNewThreadFail
        then obtain va' h' x where "P,t  aM(vs), h -NewThread ?t_a x h', ThreadStart ?t_a→ext va', h'"
          by(fastforce)
        moreover from ta = ThreadExists ?t_a True False None
        have "final_thread.actions_ok' s t NewThread ?t_a x h', ThreadStart ?t_a" by(auto)
        moreover from ta = ThreadExists ?t_a True
        have "final_thread.actions_subset NewThread ?t_a x h', ThreadStart ?t_a ta" by(auto)
        ultimately show ?thesis by blast
      next
        case RedJoin
        let ?ta = "IsInterrupted t True, ClearInterrupt t, ObsInterrupted t"
        from ta = Join (addr2thread_id a), IsInterrupted t False, ThreadJoin (addr2thread_id a) None False
        have "t  interrupts s" by(auto)
        hence "final_thread.actions_ok final s t ?ta"
          using None by(auto simp add: final_thread.actions_ok_iff final_thread.cond_action_oks.simps)
        moreover obtain va h' where "P,t  aM(vs),h -?ta→ext va,h'" using RedJoinInterrupt RedJoin by auto
        ultimately show ?thesis by blast
      next
        case RedJoinInterrupt
        hence False using False None by(auto)
        thus ?thesis ..
      next
        case RedInterrupt
        let ?ta = "ThreadExists (addr2thread_id a) False"
        from RedInterrupt None False
        have "free_thread_id (thr s) (addr2thread_id a)" by(auto simp add: wset_actions_ok_def)
        hence "final_thread.actions_ok final s t ?ta" using None
          by(auto simp add: final_thread.actions_ok_iff final_thread.cond_action_oks.simps)
        moreover obtain va h' where "P,t  aM(vs),h -?ta→ext va,h'" using RedInterruptInexist RedInterrupt by auto
        ultimately show ?thesis by blast
      next
        case RedInterruptInexist
        let ?ta = "ThreadExists (addr2thread_id a) True, WakeUp (addr2thread_id a), Interrupt (addr2thread_id a), ObsInterrupt (addr2thread_id a)"
        from RedInterruptInexist None False
        have "¬ free_thread_id (thr s) (addr2thread_id a)" by(auto simp add: wset_actions_ok_def)
        hence "final_thread.actions_ok final s t ?ta" using None
          by(auto simp add: final_thread.actions_ok_iff final_thread.cond_action_oks.simps wset_actions_ok_def)
        moreover obtain va h' where "P,t  aM(vs),h -?ta→ext va,h'" using RedInterruptInexist RedInterrupt by auto
        ultimately show ?thesis by blast
      next
        case (RedIsInterruptedTrue C)
        let ?ta' = "IsInterrupted ?t_a False"
        from RedIsInterruptedTrue False None have "?t_a  interrupts s" by(auto)
        hence "final_thread.actions_ok' s t ?ta'" using None by auto
        moreover from RedIsInterruptedTrue have "final_thread.actions_subset ?ta' ta" by auto
        moreover from RedIsInterruptedTrue RedIsInterruptedFalse obtain va h'
          where "P,t  aM(vs),h -?ta'→ext va,h'" by auto
        ultimately show ?thesis by blast
      next
        case (RedIsInterruptedFalse C)
        let ?ta' = "IsInterrupted ?t_a True, ObsInterrupted ?t_a"
        from RedIsInterruptedFalse have "?t_a  interrupts s"
          using False None by(auto)
        hence "final_thread.actions_ok final s t ?ta'"
          using None by(auto simp add: final_thread.actions_ok_iff final_thread.cond_action_oks.simps)
        moreover obtain va h' where "P,t  aM(vs),h -?ta'→ext va,h'"
          using RedIsInterruptedFalse RedIsInterruptedTrue by auto
        ultimately show ?thesis by blast
      next
        case RedWaitInterrupt
        note ta = ta = Unlocka, Locka, IsInterrupted t True, ClearInterrupt t, ObsInterrupted t
        from ta False None have hli: "¬ has_lock (locks s $ a) t  t  interrupts s"
          by(fastforce simp add: lock_actions_ok'_iff finfun_upd_apply split: if_split_asm dest: may_lock_t_may_lock_unlock_lock_t dest: has_lock_may_lock)
        show ?thesis
        proof(cases "has_lock (locks s $ a) t")
          case True
          let ?ta' = "Suspend a, Unlocka, Locka, ReleaseAcquirea, IsInterrupted t False, SyncUnlock a "
          from True hli have "t  interrupts s" by simp
          with True False have "final_thread.actions_ok' s t ?ta'" using None
            by(auto simp add: lock_actions_ok'_iff finfun_upd_apply wset_actions_ok_def Cons_eq_append_conv)
          moreover from ta have "final_thread.actions_subset ?ta' ta"
            by(auto simp add: collect_locks'_def finfun_upd_apply)
          moreover from RedWait RedWaitInterrupt obtain va h' where "P,t  aM(vs),h -?ta'→ext va,h'" by auto
          ultimately show ?thesis by blast
        next
          case False
          let ?ta' = "UnlockFaila"
          from False have "final_thread.actions_ok' s t ?ta'" using None
            by(auto simp add: lock_actions_ok'_iff finfun_upd_apply)
          moreover from ta have "final_thread.actions_subset ?ta' ta"
            by(auto simp add: collect_locks'_def finfun_upd_apply)
          moreover from RedWaitInterrupt obtain va h' where "P,t  aM(vs),h -?ta'→ext va,h'" by(fastforce)
          ultimately show ?thesis by blast
        qed
      next
        case RedWait
        note ta = ta = Suspend a, Unlocka, Locka, ReleaseAcquirea, IsInterrupted t False, SyncUnlock a

        from ta False None have hli: "¬ has_lock (locks s $ a) t  t  interrupts s"
          by(auto simp add: lock_actions_ok'_iff finfun_upd_apply wset_actions_ok_def Cons_eq_append_conv split: if_split_asm dest: may_lock_t_may_lock_unlock_lock_t dest: has_lock_may_lock)
        show ?thesis
        proof(cases "has_lock (locks s $ a) t")
          case True
          let ?ta' = "Unlocka, Locka, IsInterrupted t True, ClearInterrupt t, ObsInterrupted t"
          from True hli have "t  interrupts s" by simp
          with True False have "final_thread.actions_ok final s t ?ta'" using None
            by(auto simp add: final_thread.actions_ok_iff final_thread.cond_action_oks.simps lock_ok_las_def finfun_upd_apply has_lock_may_lock)
          moreover from RedWait RedWaitInterrupt obtain va h' where "P,t  aM(vs),h -?ta'→ext va,h'" by auto
          ultimately show ?thesis by blast
        next
          case False
          let ?ta' = "UnlockFaila"
          from False have "final_thread.actions_ok' s t ?ta'" using None
            by(auto simp add: lock_actions_ok'_iff finfun_upd_apply)
          moreover from ta have "final_thread.actions_subset ?ta' ta"
            by(auto simp add: collect_locks'_def finfun_upd_apply)
          moreover from RedWait RedWaitFail obtain va h' where "P,t  aM(vs),h -?ta'→ext va,h'" by(fastforce)
          ultimately show ?thesis by blast
        qed
      next
        case RedWaitFail
        note ta = ta = UnlockFaila
        let ?ta' = "if t  interrupts s
                   then Unlocka, Locka, IsInterrupted t True, ClearInterrupt t, ObsInterrupted t
                   else Suspend a, Unlocka, Locka, ReleaseAcquirea, IsInterrupted t False, SyncUnlock a "
        from ta False None have "has_lock (locks s $ a) t"
          by(auto simp add: finfun_upd_apply split: if_split_asm)
        hence "final_thread.actions_ok final s t ?ta'" using None
          by(auto simp add: final_thread.actions_ok_iff final_thread.cond_action_oks.simps lock_ok_las_def finfun_upd_apply has_lock_may_lock wset_actions_ok_def)
        moreover from RedWaitFail RedWait RedWaitInterrupt
        obtain va h' where "P,t  aM(vs),h -?ta'→ext va,h'"
          by(cases "t  interrupts s") (auto)
        ultimately show ?thesis by blast
      next
        case RedWaitNotified
        note ta = ta = Notified
        let ?ta' = "if has_lock (locks s $ a) t
                   then (if t  interrupts s
                         then Unlocka, Locka, IsInterrupted t True, ClearInterrupt t, ObsInterrupted t
                         else Suspend a, Unlocka, Locka, ReleaseAcquirea, IsInterrupted t False, SyncUnlock a )
                   else UnlockFaila"
        have "final_thread.actions_ok final s t ?ta'" using None
          by(auto simp add: final_thread.actions_ok_iff final_thread.cond_action_oks.simps lock_ok_las_def finfun_upd_apply has_lock_may_lock wset_actions_ok_def)
        moreover from RedWaitNotified RedWait RedWaitInterrupt RedWaitFail
        have "va h'. P,t  aM(vs),h -?ta'→ext va,h'" by auto
        ultimately show ?thesis by blast
      next
        case RedWaitInterrupted
        note ta = ta = WokenUp, ClearInterrupt t, ObsInterrupted t
        let ?ta' = "if has_lock (locks s $ a) t
                   then (if t  interrupts s
                         then Unlocka, Locka, IsInterrupted t True, ClearInterrupt t, ObsInterrupted t
                         else Suspend a, Unlocka, Locka, ReleaseAcquirea, IsInterrupted t False, SyncUnlock a )
                   else UnlockFaila"
        have "final_thread.actions_ok final s t ?ta'" using None
          by(auto simp add: final_thread.actions_ok_iff final_thread.cond_action_oks.simps lock_ok_las_def finfun_upd_apply has_lock_may_lock wset_actions_ok_def)
        moreover from RedWaitInterrupted RedWait RedWaitInterrupt RedWaitFail
        have "va h'. P,t  aM(vs),h -?ta'→ext va,h'" by auto
        ultimately show ?thesis by blast
      next
        case RedWaitSpurious
        note ta = ta = Unlocka, Locka, ReleaseAcquirea, IsInterrupted t False, SyncUnlock a
        from ta False None have hli: "¬ has_lock (locks s $ a) t  t  interrupts s"
          by(auto simp add: lock_actions_ok'_iff finfun_upd_apply wset_actions_ok_def Cons_eq_append_conv split: if_split_asm dest: may_lock_t_may_lock_unlock_lock_t dest: has_lock_may_lock)
        show ?thesis
        proof(cases "has_lock (locks s $ a) t")
          case True
          let ?ta' = "Unlocka, Locka, IsInterrupted t True, ClearInterrupt t, ObsInterrupted t"
          from True hli have "t  interrupts s" by simp
          with True False have "final_thread.actions_ok final s t ?ta'" using None
            by(auto simp add: final_thread.actions_ok_iff final_thread.cond_action_oks.simps lock_ok_las_def finfun_upd_apply has_lock_may_lock)
          moreover from RedWaitInterrupt RedWaitSpurious(1-5)
          obtain va h' where "P,t  aM(vs),h -?ta'→ext va,h'" by auto
          ultimately show ?thesis by blast
        next
          case False
          let ?ta' = "UnlockFaila"
          from False have "final_thread.actions_ok' s t ?ta'" using None
            by(auto simp add: lock_actions_ok'_iff finfun_upd_apply)
          moreover from ta have "final_thread.actions_subset ?ta' ta"
            by(auto simp add: collect_locks'_def finfun_upd_apply)
          moreover from RedWaitSpurious(1-5) RedWaitFail
          obtain va h' where "P,t  aM(vs),h -?ta'→ext va,h'" by(fastforce)
          ultimately show ?thesis by blast
        qed

      next
        case RedNotify
        note ta = ta = Notify a, Unlocka, Locka
        let ?ta' = "UnlockFaila"
        from ta False None have "¬ has_lock (locks s $ a) t"
          by(fastforce simp add: lock_actions_ok'_iff finfun_upd_apply wset_actions_ok_def Cons_eq_append_conv split: if_split_asm dest: may_lock_t_may_lock_unlock_lock_t has_lock_may_lock)
        hence "final_thread.actions_ok' s t ?ta'" using None
          by(auto simp add: lock_actions_ok'_iff finfun_upd_apply)
        moreover from ta have "final_thread.actions_subset ?ta' ta"
          by(auto simp add: collect_locks'_def finfun_upd_apply)
        moreover from RedNotify obtain va h' where "P,t  aM(vs),h -?ta'→ext va,h'" by(fastforce)
        ultimately show ?thesis by blast
      next
        case RedNotifyFail
        note ta = ta = UnlockFaila
        let ?ta' = "Notify a, Unlocka, Locka"
        from ta False None have "has_lock (locks s $ a) t"
          by(auto simp add: finfun_upd_apply split: if_split_asm)
        hence "final_thread.actions_ok' s t ?ta'" using None
          by(auto simp add: finfun_upd_apply simp add: wset_actions_ok_def intro: has_lock_may_lock)
        moreover from ta have "final_thread.actions_subset ?ta' ta"
          by(auto simp add: collect_locks'_def finfun_upd_apply)
        moreover from RedNotifyFail obtain va h' where "P,t  aM(vs),h -?ta'→ext va,h'" by(fastforce)
        ultimately show ?thesis by blast
      next
        case RedNotifyAll
        note ta = ta = NotifyAll a, Unlocka, Locka
        let ?ta' = "UnlockFaila"
        from ta False None have "¬ has_lock (locks s $ a) t"
          by(auto simp add: lock_actions_ok'_iff finfun_upd_apply wset_actions_ok_def Cons_eq_append_conv split: if_split_asm dest: may_lock_t_may_lock_unlock_lock_t)
        hence "final_thread.actions_ok' s t ?ta'" using None
          by(auto simp add: lock_actions_ok'_iff finfun_upd_apply)
        moreover from ta have "final_thread.actions_subset ?ta' ta"
          by(auto simp add: collect_locks'_def finfun_upd_apply)
        moreover from RedNotifyAll obtain va h' where "P,t  aM(vs),h -?ta'→ext va,h'" by(fastforce)
        ultimately show ?thesis by blast
      next
        case RedNotifyAllFail
        note ta = ta = UnlockFaila
        let ?ta' = "NotifyAll a, Unlocka, Locka"
        from ta False None have "has_lock (locks s $ a) t"
          by(auto simp add: finfun_upd_apply split: if_split_asm)
        hence "final_thread.actions_ok' s t ?ta'" using None
          by(auto simp add: finfun_upd_apply wset_actions_ok_def intro: has_lock_may_lock)
        moreover from ta have "final_thread.actions_subset ?ta' ta"
          by(auto simp add: collect_locks'_def finfun_upd_apply)
        moreover from RedNotifyAllFail obtain va h' where "P,t  aM(vs),h -?ta'→ext va,h'" by(fastforce)
        ultimately show ?thesis by blast
      next
        case RedInterruptedTrue
        let ?ta' = "IsInterrupted t False"
        from RedInterruptedTrue have "final_thread.actions_ok final s t ?ta'"
          using None False by(auto simp add: final_thread.actions_ok_iff final_thread.cond_action_oks.simps)
        moreover obtain va h' where "P,t  aM(vs),h -?ta'→ext va,h'"
          using RedInterruptedFalse RedInterruptedTrue by auto
        ultimately show ?thesis by blast
      next
        case RedInterruptedFalse
        let ?ta' = "IsInterrupted t True, ClearInterrupt t, ObsInterrupted t"
        from RedInterruptedFalse have "final_thread.actions_ok final s t ?ta'"
          using None False
          by(auto simp add: final_thread.actions_ok_iff final_thread.cond_action_oks.simps)
        moreover obtain va h' where "P,t  aM(vs),h -?ta'→ext va,h'"
          using RedInterruptedFalse RedInterruptedTrue by auto
        ultimately show ?thesis by blast
      qed(auto simp add: None)
    qed
  qed
qed

end

context heap_base begin

lemma red_external_ta_satisfiable:
  fixes final
  assumes "P,t  aM(vs), h -ta→ext va, h'"
  shows "s. final_thread.actions_ok final s t ta"
proof -
  note [simp] =
    final_thread.actions_ok_iff final_thread.cond_action_oks.simps final_thread.cond_action_ok.simps
    lock_ok_las_def finfun_upd_apply wset_actions_ok_def has_lock_may_lock
    and [intro] =
    free_thread_id.intros
    and [cong] = conj_cong

  from assms show ?thesis by cases(fastforce intro: exI[where x="(K$ None)(a $:= (t, 0))"] exI[where x="(K$ None)"])+
qed

lemma red_external_aggr_ta_satisfiable:
  fixes final
  assumes "(ta, va, h')  red_external_aggr P t a M vs h"
  shows "s. final_thread.actions_ok final s t ta"
proof -
  note [simp] =
    final_thread.actions_ok_iff final_thread.cond_action_oks.simps final_thread.cond_action_ok.simps
    lock_ok_las_def finfun_upd_apply wset_actions_ok_def has_lock_may_lock
    and [intro] =
    free_thread_id.intros
    and [cong] = conj_cong

  from assms show ?thesis
    by(fastforce simp add: red_external_aggr_def split_beta ta_upd_simps split: if_split_asm intro: exI[where x="Map.empty"] exI[where x="(K$ None)(a $:= (t, 0))"] exI[where x="K$ None"])
qed

end

subsection ‹Determinism›

context heap_base begin

lemma heap_copy_loc_deterministic:
  assumes det: "deterministic_heap_ops"
  and copy: "heap_copy_loc a a' al h ops h'" "heap_copy_loc a a' al h ops' h''"
  shows "ops = ops'  h' = h''"
using copy
by(auto elim!: heap_copy_loc.cases dest: deterministic_heap_ops_readD[OF det] deterministic_heap_ops_writeD[OF det])

lemma heap_copies_deterministic:
  assumes det: "deterministic_heap_ops"
  and copy: "heap_copies a a' als h ops h'" "heap_copies a a' als h ops' h''"
  shows "ops = ops'  h' = h''"
using copy
apply(induct arbitrary: ops' h'')
 apply(fastforce elim!: heap_copies_cases)
apply(erule heap_copies_cases)
apply clarify
apply(drule (1) heap_copy_loc_deterministic[OF det])
apply clarify
apply(unfold same_append_eq)
apply blast
done

lemma heap_clone_deterministic:
  assumes det: "deterministic_heap_ops"
  and clone: "heap_clone P h a h' obs" "heap_clone P h a h'' obs'"
  shows "h' = h''  obs = obs'"
using clone
by(auto 4 4 elim!: heap_clone.cases dest: heap_copies_deterministic[OF det] deterministic_heap_ops_allocateD[OF det] has_fields_fun)

lemma red_external_deterministic:
  fixes final
  assumes det: "deterministic_heap_ops"
  and red: "P,t  aM(vs), (shr s) -ta→ext va, h'" "P,t  aM(vs), (shr s) -ta'→ext va', h''"
  and aok: "final_thread.actions_ok final s t ta" "final_thread.actions_ok final s t ta'"
  shows "ta = ta'  va = va'  h' = h''"
using red aok
apply(simp add: final_thread.actions_ok_iff lock_ok_las_def)
apply(erule red_external.cases)
apply(erule_tac [!] red_external.cases)
apply simp_all
apply(auto simp add: finfun_upd_apply wset_actions_ok_def dest: heap_clone_deterministic[OF det] split: if_split_asm)
using deterministic_heap_ops_no_spurious_wakeups[OF det]
apply simp_all
done

end

end

Theory ConformThreaded

(*  Title:      JinjaThreads/Common/ConformThreaded.thy
    Author:     Andreas Lochbihler
*)

section ‹Conformance for threads›

theory ConformThreaded
imports
  "../Framework/FWLifting"
  "../Framework/FWWellform"
  Conform
begin

text ‹Every thread must be represented as an object whose address is its thread ID›

context heap_base begin

abbreviation thread_conf :: "'m prog  ('addr,'thread_id,'x) thread_info  'heap  bool"
where "thread_conf P  ts_ok (λt x m. P,m  t √t)"

lemma thread_confI:
  "(t xln. ts t = xln  P,h  t √t)  thread_conf P ts h"
by(blast intro: ts_okI)

lemma thread_confD:
  assumes "thread_conf P ts h" "ts t = xln"
  shows "P,h  t √t"
using assms by(cases xln)(auto dest: ts_okD)

lemma thread_conf_ts_upd_eq [simp]:
  assumes tst: "ts t = xln"
  shows "thread_conf P (ts(t  xln')) h  thread_conf P ts h"
proof
  assume tc: "thread_conf P (ts(t  xln')) h"
  show "thread_conf P ts h"
  proof(rule thread_confI)
    fix T XLN
    assume "ts T = XLN"
    with tc show "P,h  T √t"
      by(cases "T = t")(auto dest: thread_confD)
  qed
next
  assume tc: "thread_conf P ts h"
  show "thread_conf P (ts(t  xln')) h"
  proof(rule thread_confI)
    fix T XLN
    assume "(ts(t  xln')) T = XLN"
    with tst obtain XLN' where "ts T = XLN'"
      by(cases "T = t")(auto)
    with tc show "P,h  T √t"
      by(auto dest: thread_confD)
  qed
qed

end

context heap begin

lemma thread_conf_hext:
  " thread_conf P ts h; h  h'   thread_conf P ts h'"
by(blast intro: thread_confI tconf_hext_mono dest: thread_confD)

lemma thread_conf_start_state:
  " start_heap_ok; wf_syscls P   thread_conf P (thr (start_state f P C M vs)) (shr (start_state f P C M vs))"
by(auto intro!: thread_confI simp add: start_state_def split_beta split: if_split_asm intro: tconf_start_heap_start_tid)

end

context heap_base begin 

lemma lock_thread_ok_start_state:
  "lock_thread_ok (locks (start_state f P C M vs)) (thr (start_state f P C M vs))"
by(rule lock_thread_okI)(simp add: start_state_def split_beta)

lemma wset_thread_ok_start_state:
  "wset_thread_ok (wset (start_state f P C M vs)) (thr (start_state f P C M vs))"
by(auto simp add: wset_thread_ok_def start_state_def split_beta)

lemma wset_final_ok_start_state:
  "final_thread.wset_final_ok final (wset (start_state f P C M vs)) (thr (start_state f P C M vs))"
by(rule final_thread.wset_final_okI)(simp add: start_state_def split_beta)

end

end

Theory BinOp

(*  Title:      JinjaThreads/Common/BinOp.thy
    Author:     Andreas Lochbihler
*)

section ‹Binary Operators›

theory BinOp
imports
  WellForm "Word_Lib.Traditional_Infix_Syntax"
begin

datatype bop =  ― ‹names of binary operations›
    Eq
  | NotEq
  | LessThan
  | LessOrEqual
  | GreaterThan
  | GreaterOrEqual
  | Add    
  | Subtract
  | Mult
  | Div
  | Mod
  | BinAnd
  | BinOr
  | BinXor
  | ShiftLeft
  | ShiftRightZeros
  | ShiftRightSigned

subsection‹The semantics of binary operators›

type_synonym 'addr binop_ret = "'addr val + 'addr" ― ‹a value or the address of an exception›

fun binop_LessThan :: "'addr val  'addr val  'addr binop_ret option"
where
  "binop_LessThan (Intg i1) (Intg i2) = Some (Inl (Bool (i1 <s i2)))"
| "binop_LessThan v1 v2 = None"

fun binop_LessOrEqual :: "'addr val  'addr val  'addr binop_ret option"
where
  "binop_LessOrEqual (Intg i1) (Intg i2) = Some (Inl (Bool (i1 <=s i2)))"
| "binop_LessOrEqual v1 v2 = None"

fun binop_GreaterThan :: "'addr val  'addr val  'addr binop_ret option"
where
  "binop_GreaterThan (Intg i1) (Intg i2) = Some (Inl (Bool (i2 <s i1)))"
| "binop_GreaterThan v1 v2 = None"

fun binop_GreaterOrEqual :: "'addr val  'addr val  'addr binop_ret option"
where
  "binop_GreaterOrEqual (Intg i1) (Intg i2) = Some (Inl (Bool (i2 <=s i1)))"
| "binop_GreaterOrEqual v1 v2 = None"

fun binop_Add :: "'addr val  'addr val  'addr binop_ret option"
where
  "binop_Add (Intg i1) (Intg i2) = Some (Inl (Intg (i1 + i2)))"
| "binop_Add v1 v2 = None"

fun binop_Subtract :: "'addr val  'addr val  'addr binop_ret option"
where
  "binop_Subtract (Intg i1) (Intg i2) = Some (Inl (Intg (i1 - i2)))"
| "binop_Subtract v1 v2 = None"

fun binop_Mult :: "'addr val  'addr val  'addr binop_ret option"
where
  "binop_Mult (Intg i1) (Intg i2) = Some (Inl (Intg (i1 * i2)))"
| "binop_Mult v1 v2 = None"

fun binop_BinAnd :: "'addr val  'addr val  'addr binop_ret option"
where
  "binop_BinAnd (Intg i1) (Intg i2) = Some (Inl (Intg (i1 AND i2)))"
| "binop_BinAnd (Bool b1) (Bool b2) = Some (Inl (Bool (b1  b2)))"
| "binop_BinAnd v1 v2 = None"

fun binop_BinOr :: "'addr val  'addr val  'addr binop_ret option"
where
  "binop_BinOr (Intg i1) (Intg i2) = Some (Inl (Intg (i1 OR i2)))"
| "binop_BinOr (Bool b1) (Bool b2) = Some (Inl (Bool (b1  b2)))"
| "binop_BinOr v1 v2 = None"

fun binop_BinXor :: "'addr val  'addr val  'addr binop_ret option"
where
  "binop_BinXor (Intg i1) (Intg i2) = Some (Inl (Intg (i1 XOR i2)))"
| "binop_BinXor (Bool b1) (Bool b2) = Some (Inl (Bool (b1  b2)))"
| "binop_BinXor v1 v2 = None"

fun binop_ShiftLeft :: "'addr val  'addr val  'addr binop_ret option"
where
  "binop_ShiftLeft (Intg i1) (Intg i2) = Some (Inl (Intg (i1 << unat (i2 AND 0x1f))))"
| "binop_ShiftLeft v1 v2 = None"

fun binop_ShiftRightZeros :: "'addr val  'addr val  'addr binop_ret option"
where
  "binop_ShiftRightZeros (Intg i1) (Intg i2) = Some (Inl (Intg (i1 >> unat (i2 AND 0x1f))))"
| "binop_ShiftRightZeros v1 v2 = None"

fun binop_ShiftRightSigned :: "'addr val  'addr val  'addr binop_ret option"
where
  "binop_ShiftRightSigned (Intg i1) (Intg i2) = Some (Inl (Intg (i1 >>> unat (i2 AND 0x1f))))"
| "binop_ShiftRightSigned v1 v2 = None"

text ‹
  Division on @{typ "'a word"} is unsigned, but JLS specifies signed division.
›
definition word_sdiv :: "'a :: len word  'a word  'a word" (infixl "sdiv" 70)
where [code]:
  "x sdiv y =
   (let x' = sint x; y' = sint y;
        negative = (x' < 0)  (y' < 0);
        result = abs x' div abs y'
    in word_of_int (if negative then -result else result))"

definition word_smod :: "'a :: len word  'a word  'a word" (infixl "smod" 70)
where [code]:
  "x smod y =
   (let x' = sint x; y' = sint y;
        negative = (x' < 0);
        result = abs x' mod abs y'
    in word_of_int (if negative then -result else result))"

declare word_sdiv_def [simp] word_smod_def [simp]

lemma sdiv_smod_id: "(a sdiv b) * b + (a smod b) = a"
proof -
  have F5: "u::'a word. - (- u) = u"
    by simp
  have F7: "v u::'a word. u + v = v + u"
    by (simp add: ac_simps)
  have F8: "(w::'a word) (v::int) u::int. word_of_int u + word_of_int v * w = word_of_int (u + v * sint w)"
    by simp
  have "u. u = - sint b  word_of_int (sint a mod u + - (- u * (sint a div u))) = a"
    using F5 by simp
  hence "word_of_int (sint a mod - sint b + - (sint b * (sint a div - sint b))) = a"
    by (metis equation_minus_iff)
  hence "word_of_int (sint a mod - sint b) + word_of_int (- (sint a div - sint b)) * b = a"
    using F8 by (simp add: ac_simps)
  hence eq: "word_of_int (- (sint a div - sint b)) * b + word_of_int (sint a mod - sint b) = a"
    using F7 by simp

  show ?thesis
  proof(cases "sint a < 0")
    case True note a = this
    show ?thesis
    proof(cases "sint b < 0")
      case True
      with a show ?thesis
        by simp (metis F7 F8 eq minus_equation_iff minus_mult_minus mod_div_mult_eq)
    next
      case False
      from eq have "word_of_int (- (- sint a div sint b)) * b + word_of_int (- (- sint a mod sint b)) = a"
        by (metis div_minus_right mod_minus_right)
      with a False show ?thesis by simp
    qed
  next
    case False note a = this
    show ?thesis
    proof(cases "sint b < 0")
      case True
      with a eq show ?thesis by simp
    next
      case False with a show ?thesis
        by (simp add: F7 F8)
    qed
  qed
qed

notepad begin
have  "  5  sdiv ( 3 :: word32) =  1"
  and "  5  smod ( 3 :: word32) =  2"
  and "  5  sdiv (-3 :: word32) = -1"
  and "  5  smod (-3 :: word32) =  2"
  and "(-5) sdiv ( 3 :: word32) = -1"
  and "(-5) smod ( 3 :: word32) = -2"
  and "(-5) sdiv (-3 :: word32) =  1"
  and "(-5) smod (-3 :: word32) = -2"
  and "-2147483648 sdiv 1 = (-2147483648 :: word32)"
  by eval+
end

context heap_base begin

fun binop_Mod :: "'addr val  'addr val  'addr binop_ret option"
where
  "binop_Mod (Intg i1) (Intg i2) = 
   Some (if i2 = 0 then Inr (addr_of_sys_xcpt ArithmeticException) else Inl (Intg (i1 smod i2)))"
| "binop_Mod v1 v2 = None"

fun binop_Div :: "'addr val  'addr val  'addr binop_ret option"
where
  "binop_Div (Intg i1) (Intg i2) = 
   Some (if i2 = 0 then Inr (addr_of_sys_xcpt ArithmeticException) else Inl (Intg (i1 sdiv i2)))"
| "binop_Div v1 v2 = None"

primrec binop :: "bop  'addr val  'addr val  'addr binop_ret option"
where
  "binop Eq v1 v2 =  Some (Inl (Bool (v1 = v2)))"
| "binop NotEq v1 v2 = Some (Inl (Bool (v1  v2)))"
| "binop LessThan = binop_LessThan"
| "binop LessOrEqual = binop_LessOrEqual"
| "binop GreaterThan = binop_GreaterThan"
| "binop GreaterOrEqual = binop_GreaterOrEqual"
| "binop Add = binop_Add"
| "binop Subtract = binop_Subtract"
| "binop Mult = binop_Mult"
| "binop Mod = binop_Mod"
| "binop Div = binop_Div"
| "binop BinAnd = binop_BinAnd"
| "binop BinOr = binop_BinOr"
| "binop BinXor = binop_BinXor"
| "binop ShiftLeft = binop_ShiftLeft"
| "binop ShiftRightZeros = binop_ShiftRightZeros"
| "binop ShiftRightSigned = binop_ShiftRightSigned"

end

lemma [simp]:
  "(binop_LessThan v1 v2 = Some va)  
   (i1 i2. v1 = Intg i1  v2 = Intg i2  va = Inl (Bool (i1 <s i2)))"
by(cases "(v1, v2)" rule: binop_LessThan.cases) auto

lemma [simp]:
  "(binop_LessOrEqual v1 v2 = Some va)  
   (i1 i2. v1 = Intg i1  v2 = Intg i2  va = Inl (Bool (i1 <=s i2)))"
by(cases "(v1, v2)" rule: binop_LessOrEqual.cases) auto

lemma [simp]:
  "(binop_GreaterThan v1 v2 = Some va)  
   (i1 i2. v1 = Intg i1  v2 = Intg i2  va = Inl (Bool (i2 <s i1)))"
by(cases "(v1, v2)" rule: binop_GreaterThan.cases) auto

lemma [simp]:
  "(binop_GreaterOrEqual v1 v2 = Some va)  
   (i1 i2. v1 = Intg i1  v2 = Intg i2  va = Inl (Bool (i2 <=s i1)))"
by(cases "(v1, v2)" rule: binop_GreaterOrEqual.cases) auto

lemma [simp]:
  "(binop_Add v1 v2  = Some va) 
   (i1 i2. v1 = Intg i1  v2 = Intg i2  va = Inl (Intg (i1+i2)))"
by(cases "(v1, v2)" rule: binop_Add.cases) auto

lemma [simp]:
  "(binop_Subtract v1 v2 = Some va)  
   (i1 i2. v1 = Intg i1  v2 = Intg i2  va = Inl (Intg (i1 - i2)))"
by(cases "(v1, v2)" rule: binop_Subtract.cases) auto

lemma [simp]: 
  "(binop_Mult v1 v2 = Some va)  
   (i1 i2. v1 = Intg i1  v2 = Intg i2  va = Inl (Intg (i1 * i2)))"
by(cases "(v1, v2)" rule: binop_Mult.cases) auto

lemma [simp]:
  "(binop_BinAnd v1 v2 = Some va)  
   (b1 b2. v1 = Bool b1  v2 = Bool b2  va = Inl (Bool (b1  b2)))  
   (i1 i2. v1 = Intg i1  v2 = Intg i2  va = Inl (Intg (i1 AND i2)))"
by(cases "(v1, v2)" rule: binop_BinAnd.cases) auto

lemma [simp]:
  "(binop_BinOr v1 v2 = Some va)  
   (b1 b2. v1 = Bool b1  v2 = Bool b2  va = Inl (Bool (b1  b2))) 
   (i1 i2. v1 = Intg i1  v2 = Intg i2  va = Inl (Intg (i1 OR i2)))"
by(cases "(v1, v2)" rule: binop_BinOr.cases) auto

lemma [simp]:
  "(binop_BinXor v1 v2 = Some va) 
   (b1 b2. v1 = Bool b1  v2 = Bool b2  va = Inl (Bool (b1  b2))) 
   (i1 i2. v1 = Intg i1  v2 = Intg i2  va = Inl (Intg (i1 XOR i2)))"
by(cases "(v1, v2)" rule: binop_BinXor.cases) auto

lemma [simp]:
  "(binop_ShiftLeft v1 v2 = Some va)  
   (i1 i2. v1 = Intg i1  v2 = Intg i2  va = Inl (Intg (i1 << unat (i2 AND 0x1f))))"
by(cases "(v1, v2)" rule: binop_ShiftLeft.cases) auto

lemma [simp]:
  "(binop_ShiftRightZeros v1 v2 = Some va)  
   (i1 i2. v1 = Intg i1  v2 = Intg i2  va = Inl (Intg (i1 >> unat (i2 AND 0x1f))))"
by(cases "(v1, v2)" rule: binop_ShiftRightZeros.cases) auto

lemma [simp]:
  "(binop_ShiftRightSigned v1 v2 = Some va)  
   (i1 i2. v1 = Intg i1  v2 = Intg i2  va = Inl (Intg (i1 >>> unat (i2 AND 0x1f))))"
by(cases "(v1, v2)" rule: binop_ShiftRightSigned.cases) auto

context heap_base begin

lemma [simp]:
  "(binop_Mod v1 v2 = Some va)  
   (i1 i2. v1 = Intg i1  v2 = Intg i2  
      va = (if i2 = 0 then Inr (addr_of_sys_xcpt ArithmeticException) else Inl (Intg(i1 smod i2))))"
by(cases "(v1, v2)" rule: binop_Mod.cases) auto

lemma [simp]:
  "(binop_Div v1 v2 = Some va)  
   (i1 i2. v1 = Intg i1  v2 = Intg i2  
      va = (if i2 = 0 then Inr (addr_of_sys_xcpt ArithmeticException) else Inl (Intg(i1 sdiv i2))))"
by(cases "(v1, v2)" rule: binop_Div.cases) auto

end

subsection ‹Typing for binary operators›

inductive WT_binop :: "'m prog  ty  bop  ty  ty  bool" ("_  _«_»_ :: _" [51,0,0,0,51] 50)
where
  WT_binop_Eq:
  "P  T1  T2  P  T2  T1  P  T1«Eq»T2 :: Boolean"

| WT_binop_NotEq:
  "P  T1  T2  P  T2  T1  P  T1«NotEq»T2 :: Boolean"

| WT_binop_LessThan:
  "P  Integer«LessThan»Integer :: Boolean"

| WT_binop_LessOrEqual:
  "P  Integer«LessOrEqual»Integer :: Boolean"

| WT_binop_GreaterThan:
  "P  Integer«GreaterThan»Integer :: Boolean"

| WT_binop_GreaterOrEqual:
  "P  Integer«GreaterOrEqual»Integer :: Boolean"

| WT_binop_Add:
  "P  Integer«Add»Integer :: Integer"

| WT_binop_Subtract:
  "P  Integer«Subtract»Integer :: Integer"

| WT_binop_Mult:
  "P  Integer«Mult»Integer :: Integer"

| WT_binop_Div:
  "P  Integer«Div»Integer :: Integer"

| WT_binop_Mod:
  "P  Integer«Mod»Integer :: Integer"

| WT_binop_BinAnd_Bool:
  "P  Boolean«BinAnd»Boolean :: Boolean"

| WT_binop_BinAnd_Int:
  "P  Integer«BinAnd»Integer :: Integer"

| WT_binop_BinOr_Bool:
  "P  Boolean«BinOr»Boolean :: Boolean"

| WT_binop_BinOr_Int:
  "P  Integer«BinOr»Integer :: Integer"

| WT_binop_BinXor_Bool:
  "P  Boolean«BinXor»Boolean :: Boolean"

| WT_binop_BinXor_Int:
  "P  Integer«BinXor»Integer :: Integer"

| WT_binop_ShiftLeft:
  "P  Integer«ShiftLeft»Integer :: Integer"

| WT_binop_ShiftRightZeros:
  "P  Integer«ShiftRightZeros»Integer :: Integer"

| WT_binop_ShiftRightSigned:
  "P  Integer«ShiftRightSigned»Integer :: Integer"

lemma WT_binopI [intro]:
  "P  T1  T2  P  T2  T1  P  T1«Eq»T2 :: Boolean"
  "P  T1  T2  P  T2  T1  P  T1«NotEq»T2 :: Boolean"
  "bop = Add  bop = Subtract  bop = Mult  bop = Mod  bop = Div  bop = BinAnd  bop = BinOr  bop = BinXor  
   bop = ShiftLeft  bop = ShiftRightZeros  bop = ShiftRightSigned
    P  Integer«bop»Integer :: Integer"
  "bop = LessThan  bop = LessOrEqual  bop = GreaterThan  bop = GreaterOrEqual  P  Integer«bop»Integer :: Boolean"
  "bop = BinAnd  bop = BinOr  bop = BinXor  P  Boolean«bop»Boolean :: Boolean"
by(auto intro: WT_binop.intros)

inductive_cases [elim]:
  "P  T1«Eq»T2 :: T"
  "P  T1«NotEq»T2 :: T"
  "P  T1«LessThan»T2 :: T"
  "P  T1«LessOrEqual»T2 :: T"
  "P  T1«GreaterThan»T2 :: T"
  "P  T1«GreaterOrEqual»T2 :: T"
  "P  T1«Add»T2 :: T"
  "P  T1«Subtract»T2 :: T"
  "P  T1«Mult»T2 :: T"
  "P  T1«Div»T2 :: T"
  "P  T1«Mod»T2 :: T"
  "P  T1«BinAnd»T2 :: T"
  "P  T1«BinOr»T2 :: T"
  "P  T1«BinXor»T2 :: T"
  "P  T1«ShiftLeft»T2 :: T"
  "P  T1«ShiftRightZeros»T2 :: T"
  "P  T1«ShiftRightSigned»T2 :: T"

lemma WT_binop_fun: " P  T1«bop»T2 :: T; P  T1«bop»T2 :: T'   T = T'"
by(cases bop)(auto)

lemma WT_binop_is_type:
  " P  T1«bop»T2 :: T; is_type P T1; is_type P T2   is_type P T"
by(cases bop) auto

inductive WTrt_binop :: "'m prog  ty  bop  ty  ty  bool" ("_  _«_»_ : _" [51,0,0,0,51] 50)
where
  WTrt_binop_Eq:
  "P  T1«Eq»T2 : Boolean"

| WTrt_binop_NotEq:
  "P  T1«NotEq»T2 : Boolean"

| WTrt_binop_LessThan:
  "P  Integer«LessThan»Integer : Boolean"

| WTrt_binop_LessOrEqual:
  "P  Integer«LessOrEqual»Integer : Boolean"

| WTrt_binop_GreaterThan:
  "P  Integer«GreaterThan»Integer : Boolean"

| WTrt_binop_GreaterOrEqual:
  "P  Integer«GreaterOrEqual»Integer : Boolean"

| WTrt_binop_Add:
  "P  Integer«Add»Integer : Integer"

| WTrt_binop_Subtract:
  "P  Integer«Subtract»Integer : Integer"

| WTrt_binop_Mult:
  "P  Integer«Mult»Integer : Integer"

| WTrt_binop_Div:
  "P  Integer«Div»Integer : Integer"

| WTrt_binop_Mod:
  "P  Integer«Mod»Integer : Integer"

| WTrt_binop_BinAnd_Bool:
  "P  Boolean«BinAnd»Boolean : Boolean"

| WTrt_binop_BinAnd_Int:
  "P  Integer«BinAnd»Integer : Integer"

| WTrt_binop_BinOr_Bool:
  "P  Boolean«BinOr»Boolean : Boolean"

| WTrt_binop_BinOr_Int:
  "P  Integer«BinOr»Integer : Integer"

| WTrt_binop_BinXor_Bool:
  "P  Boolean«BinXor»Boolean : Boolean"

| WTrt_binop_BinXor_Int:
  "P  Integer«BinXor»Integer : Integer"

| WTrt_binop_ShiftLeft:
  "P  Integer«ShiftLeft»Integer : Integer"

| WTrt_binop_ShiftRightZeros:
  "P  Integer«ShiftRightZeros»Integer : Integer"

| WTrt_binop_ShiftRightSigned:
  "P  Integer«ShiftRightSigned»Integer : Integer"

lemma WTrt_binopI [intro]:
  "P  T1«Eq»T2 : Boolean"
  "P  T1«NotEq»T2 : Boolean"
  "bop = Add  bop = Subtract  bop = Mult  bop = Div  bop = Mod  bop = BinAnd  bop = BinOr  bop = BinXor 
   bop = ShiftLeft  bop = ShiftRightZeros  bop = ShiftRightSigned
    P  Integer«bop»Integer : Integer"
  "bop = LessThan  bop = LessOrEqual  bop = GreaterThan  bop = GreaterOrEqual  P  Integer«bop»Integer : Boolean"
  "bop = BinAnd  bop = BinOr  bop = BinXor  P  Boolean«bop»Boolean : Boolean"
by(auto intro: WTrt_binop.intros)

inductive_cases WTrt_binop_cases [elim]:
  "P  T1«Eq»T2 : T"
  "P  T1«NotEq»T2 : T"
  "P  T1«LessThan»T2 : T"
  "P  T1«LessOrEqual»T2 : T"
  "P  T1«GreaterThan»T2 : T"
  "P  T1«GreaterOrEqual»T2 : T"
  "P  T1«Add»T2 : T"
  "P  T1«Subtract»T2 : T"
  "P  T1«Mult»T2 : T"
  "P  T1«Div»T2 : T"
  "P  T1«Mod»T2 : T"
  "P  T1«BinAnd»T2 : T"
  "P  T1«BinOr»T2 : T"
  "P  T1«BinXor»T2 : T"
  "P  T1«ShiftLeft»T2 : T"
  "P  T1«ShiftRightZeros»T2 : T"
  "P  T1«ShiftRightSigned»T2 : T"

inductive_simps WTrt_binop_simps [simp]:
  "P  T1«Eq»T2 : T"
  "P  T1«NotEq»T2 : T"
  "P  T1«LessThan»T2 : T"
  "P  T1«LessOrEqual»T2 : T"
  "P  T1«GreaterThan»T2 : T"
  "P  T1«GreaterOrEqual»T2 : T"
  "P  T1«Add»T2 : T"
  "P  T1«Subtract»T2 : T"
  "P  T1«Mult»T2 : T"
  "P  T1«Div»T2 : T"
  "P  T1«Mod»T2 : T"
  "P  T1«BinAnd»T2 : T"
  "P  T1«BinOr»T2 : T"
  "P  T1«BinXor»T2 : T"
  "P  T1«ShiftLeft»T2 : T"
  "P  T1«ShiftRightZeros»T2 : T"
  "P  T1«ShiftRightSigned»T2 : T"

fun binop_relevant_class :: "bop  'm prog  cname  bool"
where
  "binop_relevant_class Div = (λP C. P  ArithmeticException * C )"
| "binop_relevant_class Mod = (λP C. P  ArithmeticException * C )"
| "binop_relevant_class _ = (λP C. False)"

lemma WT_binop_WTrt_binop:
  "P  T1«bop»T2 :: T  P  T1«bop»T2 : T"
by(auto elim: WT_binop.cases)

context heap begin

lemma binop_progress:
  " typeofh v1 = T1; typeofh v2 = T2; P  T1«bop»T2 : T 
   va. binop bop v1 v2 = va"
by(cases bop)(auto del: disjCI split del: if_split)

lemma binop_type:
  assumes wf: "wf_prog wf_md P"
  and pre: "preallocated h"
  and type: "typeofh v1 = T1" "typeofh v2 = T2" "P  T1«bop»T2 : T"
  shows "binop bop v1 v2 = Inl v  P,h  v :≤ T"
  and "binop bop v1 v2 = Inr a  P,h  Addr a :≤ Class Throwable"
using type
apply(case_tac [!] bop)
apply(auto split: if_split_asm simp add: conf_def wf_preallocatedD[OF wf pre])
done

lemma binop_relevant_class:
  assumes wf: "wf_prog wf_md P"
  and pre: "preallocated h"
  and bop: "binop bop v1 v2 = Inr a"
  and sup: "P  cname_of h a * C"
  shows "binop_relevant_class bop P C"
using assms
by(cases bop)(auto split: if_split_asm)

end

lemma WTrt_binop_fun: " P  T1«bop»T2 : T; P  T1«bop»T2 : T'   T = T'"
by(cases bop)(auto)

lemma WTrt_binop_THE [simp]: "P  T1«bop»T2 : T  The (WTrt_binop P T1 bop T2) = T"
by(auto dest: WTrt_binop_fun)

lemma WTrt_binop_widen_mono:
  " P  T1«bop»T2 : T; P  T1'  T1; P  T2'  T2   T'. P  T1'«bop»T2' : T'  P  T'  T"
by(cases bop)(auto elim!: WTrt_binop_cases)

lemma WTrt_binop_is_type:
  " P  T1«bop»T2 : T; is_type P T1; is_type P T2   is_type P T"
by(cases bop) auto

subsection ‹Code generator setup›

lemmas [code] =
  heap_base.binop_Div.simps
  heap_base.binop_Mod.simps
  heap_base.binop.simps

code_pred 
  (modes: i ⇒ i ⇒ i ⇒ i ⇒ o ⇒ bool, i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ bool)
  WT_binop
.

code_pred
  (modes: i ⇒ i ⇒ i ⇒ i ⇒ o ⇒ bool, i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ bool)
  WTrt_binop
.

lemma eval_WTrt_binop_i_i_i_i_o:
  "Predicate.eval (WTrt_binop_i_i_i_i_o P T1 bop T2) T  P  T1«bop»T2 : T"
by(auto elim: WTrt_binop_i_i_i_i_oE intro: WTrt_binop_i_i_i_i_oI)

lemma the_WTrt_binop_code:
  "(THE T. P  T1«bop»T2 : T) = Predicate.the (WTrt_binop_i_i_i_i_o P T1 bop T2)"
by(simp add: Predicate.the_def eval_WTrt_binop_i_i_i_i_o)

end

Theory SemiType

(*  Title:      JinjaThreads/Common/SemiType.thy
    Author:     Tobias Nipkow, Gerwin Klein, Andreas Lochbihler
*)

section ‹The Jinja Type System as a Semilattice›

theory SemiType
imports
  WellForm
  "../DFA/Semilattices"
begin

inductive_set
  widen1 :: "'a prog  (ty × ty) set"
  and widen1_syntax :: "'a prog  ty  ty  bool" ("_  _ <1 _" [71,71,71] 70)
  for P :: "'a prog"
where
  "P  C <1 D  (C, D)  widen1 P"

| widen1_Array_Object:
  "P  Array (Class Object) <1 Class Object"

| widen1_Array_Integer:
  "P  Array Integer <1 Class Object"

| widen1_Array_Boolean:
  "P  Array Boolean <1 Class Object"

| widen1_Array_Void:
  "P  Array Void <1 Class Object"

| widen1_Class: 
  "P  C 1 D  P  Class C <1 Class D"

| widen1_Array_Array:
  " P  T <1 U; ¬ is_NT_Array T   P  Array T <1 Array U"

abbreviation widen1_trancl :: "'a prog  ty  ty  bool" ("_  _ <+ _" [71,71,71] 70) where
  "P  T <+ U  (T, U)  trancl (widen1 P)"

abbreviation widen1_rtrancl :: "'a prog  ty  ty  bool" ("_  _ <* _" [71,71,71] 70) where
  "P  T <* U  (T, U)  rtrancl (widen1 P)"

inductive_simps widen1_simps1 [simp]:
  "P  Integer <1 T"
  "P  Boolean <1 T"
  "P  Void <1 T"
  "P  Class Object <1 T"
  "P  NT <1 U"

inductive_simps widen1_simps [simp]:
  "P  Array (Class Object) <1 T"
  "P  Array Integer <1 T"
  "P  Array Boolean <1 T"
  "P  Array Void <1 T"
  "P  Class C <1 T"
  "P  T <1 Array U"

lemma is_type_widen1: 
  assumes icO: "is_class P Object"
  shows "P  T <1 U  is_type P T"
by(induct rule: widen1.induct)(auto intro: subcls_is_class icO split: ty.split dest: is_type_ground_type)

lemma widen1_NT_Array:
  assumes "is_NT_Array T"
  shows "¬ P  T⌊⌉ <1 U"
proof
  assume "P  T⌊⌉ <1 U" thus False using assms
    by(induct "T⌊⌉" U arbitrary: T) auto
qed

lemma widen1_is_type:
  assumes wfP: "wf_prog wfmd P"
  shows "(A, B)  widen1 P  is_type P B"
proof(induct rule: widen1.induct)
  case (widen1_Class C D)
  hence "is_class P C" "is_class P D"
    by(auto intro: subcls_is_class converse_subcls_is_class[OF wfP])
  thus ?case by simp
next
  case (widen1_Array_Array T U)
  thus ?case by(cases U)(auto elim: widen1.cases)
qed(insert wfP, auto)

lemma widen1_trancl_is_type:
  assumes wfP: "wf_prog wfmd P"
  shows "(A, B)  (widen1 P)^+  is_type P B"
apply(induct rule: trancl_induct)
apply(auto intro: widen1_is_type[OF wfP])
done

lemma single_valued_widen1:
  assumes wf: "wf_prog wf_md P"
  shows "single_valued (widen1 P)"
proof(rule single_valuedI)
  fix x y z
  assume "P  x <1 y" "P  x <1 z"
  thus "y = z"
  proof(induct arbitrary: z rule: widen1.induct)
    case widen1_Class
    with single_valued_subcls1[OF wf] show ?case
      by(auto dest: single_valuedpD)
  next
    case (widen1_Array_Array T U z)
    from P  T⌊⌉ <1 z P  T <1 U ¬ is_NT_Array T
    obtain z' where z': "z = z'⌊⌉" and Tz': "P  T <1 z'"
      by(auto elim: widen1.cases)
    with P  T <1 z'  U = z' have "U = z'" by blast
    with z' show ?case by simp
  qed simp_all
qed

function inheritance_level :: "'a prog  cname  nat" where
  "inheritance_level P C =
   (if acyclicP (subcls1 P)  is_class P C  C  Object
    then Suc (inheritance_level P (fst (the (class P C))))
    else 0)"
by(pat_completeness, auto)
termination
proof(relation "same_fst (λP. acyclicP (subcls1 P)) (λP. {(C, C'). (subcls1 P)¯¯ C C'})")
  show "wf (same_fst (λP. acyclicP (subcls1 P)) (λP. {(C, C'). (subcls1 P)¯¯ C C'}))"
    by(rule wf_same_fst)(rule acyclicP_wf_subcls1[unfolded wfP_def])
qed(auto simp add: is_class_def intro: subcls1I)

fun subtype_measure :: "'a prog  ty  nat" where
  "subtype_measure P (Class C) = inheritance_level P C"
| "subtype_measure P (Array T) = 1 + subtype_measure P T"
| "subtype_measure P T = 0"

lemma subtype_measure_measure:
  assumes acyclic: "acyclicP (subcls1 P)"
  and widen1: "P  x <1 y"
  shows "subtype_measure P y < subtype_measure P x"
using widen1
proof(induct rule: widen1.induct)
  case (widen1_Class C D)
  then obtain rest where "is_class P C" "C  Object" "class P C = (D, rest)"
    by(auto elim!: subcls1.cases simp: is_class_def)
  thus ?case using acyclic by(simp)
qed(simp_all)

lemma wf_converse_widen1:
  assumes wfP: "wf_prog wfmc P"
  shows "wf ((widen1 P)^-1)"
proof(rule wf_subset)
  from wfP have "acyclicP (subcls1 P)" by(rule acyclic_subcls1)
  thus "(widen1 P)¯  measure (subtype_measure P)" 
    by(auto dest: subtype_measure_measure)
qed simp

fun super :: "'a prog  ty  ty"
where
  "super P (Array Integer) = Class Object"
| "super P (Array Boolean) = Class Object"
| "super P (Array Void) = Class Object"
| "super P (Array (Class C)) = (if C = Object then Class Object else Array (super P (Class C)))"
| "super P (Array (Array T)) = Array (super P (Array T))"
| "super P (Class C) = Class (fst (the (class P C)))"

lemma superI:
  "P  T <1 U  super P T = U"
proof(induct rule: widen1.induct)
  case (widen1_Array_Array T U)
  thus ?case by(cases T) auto
qed(auto dest: subcls1D)

lemma Class_widen1_super:
  "P  Class C' <1 U'  is_class P C'  C'  Object  U' = super P (Class C')"
  (is "?lhs  ?rhs")
proof(rule iffI)
  assume ?lhs thus ?rhs
    by(auto intro: subcls_is_class simp add: superI simp del: super.simps)
next
  assume ?rhs thus ?lhs
    by(auto simp add: is_class_def intro: subcls1.intros)
qed

lemma super_widen1:
  assumes icO: "is_class P Object"
  shows "P  T <1 U  is_type P T  (case T of Class C   (C  Object  U = super P T) 
                                              | Array T'  U = super P T 
                                              | _         False)"
proof(induct T arbitrary: U)
  case Class thus ?case using Class_widen1_super by(simp)
next
  case (Array T' U')
  note IH = this
  have "P  T'⌊⌉ <1 U' = (is_type P (T'⌊⌉)  U' = super P (T'⌊⌉))"
  proof(rule iffI)
    assume wd: "P  T'⌊⌉ <1 U'"
    with icO have "is_type P (T'⌊⌉)" by(rule is_type_widen1)
    moreover from wd have "super P (T'⌊⌉) = U'" by(rule superI)
    ultimately show "is_type P (T'⌊⌉)  U' = super P (T'⌊⌉)" by simp
  next
    assume "is_type P (T'⌊⌉)  U' = super P (T'⌊⌉)"
    then obtain "is_type P (T'⌊⌉)" and U': "U' = super P (T'⌊⌉)" ..
    thus "P  T'⌊⌉ <1 U'"
    proof(cases T')
      case (Class D)
      thus ?thesis using U' icO ‹is_type P (T'⌊⌉)
        by(cases "D = Object")(auto simp add: is_class_def intro: subcls1.intros)
    next
      case Array thus ?thesis
        using IH ‹is_type P (T'⌊⌉) U' by(auto simp add: ty.split_asm)
    qed simp_all
  qed
  thus ?case by(simp)
qed(simp_all)

definition sup :: "'c prog  ty  ty  ty err" where
  "sup P T U 
   if is_refT T  is_refT U
   then OK (if U = NT then T
            else if T = NT then U
            else exec_lub (widen1 P) (super P) T U)
   else if (T = U) then OK T else Err"

lemma sup_def':
  "sup P = (λT U.
   if is_refT T  is_refT U
   then OK (if U = NT then T
            else if T = NT then U
            else exec_lub (widen1 P) (super P) T U)
   else if (T = U) then OK T else Err)"
  by (simp add: fun_eq_iff sup_def)

definition esl :: "'m prog  ty esl"
where
  "esl P = (types P, widen P, sup P)"

lemma order_widen [intro,simp]: 
  "wf_prog m P  order (widen P)"
unfolding Semilat.order_def lesub_def
by (auto intro: widen_trans widen_antisym)

lemma subcls1_trancl_widen1_trancl:
  "(subcls1 P)^++ C D  P  Class C <+ Class D"
by(induct rule: tranclp_induct[consumes 1, case_names base step])
  (auto intro: trancl_into_trancl)

lemma subcls_into_widen1_rtrancl:
  "P  C * D  P  Class C <* Class D"
by(induct rule: rtranclp_induct)(auto intro: rtrancl_into_rtrancl)

lemma not_widen1_NT_Array:
  "P  U <1 T  ¬ is_NT_Array T"
by(induct rule: widen1.induct)(auto)

lemma widen1_trancl_into_Array_widen1_trancl:
  " P  A <+ B; ¬ is_NT_Array A   P  A⌊⌉ <+ B⌊⌉"
by(induct rule: converse_trancl_induct)
  (auto intro: trancl_into_trancl2 widen1_Array_Array dest: not_widen1_NT_Array)

lemma widen1_rtrancl_into_Array_widen1_rtrancl:
  " P  A <* B; ¬ is_NT_Array A   P  A⌊⌉ <* B⌊⌉"
by(blast elim: rtranclE intro: trancl_into_rtrancl widen1_trancl_into_Array_widen1_trancl rtrancl_into_trancl1)

lemma Array_Object_widen1_trancl:
  assumes wf: "wf_prog wmdc P"
  and itA: "is_type P (A⌊⌉)"
  shows "P  A⌊⌉ <+ Class Object"
using itA
proof(induction A)
  case (Class C)
  hence "is_class P C" by simp
  hence "P  C * Object" by(rule subcls_C_Object[OF _ wf])
  hence "P  Class C <* Class Object" by(rule subcls_into_widen1_rtrancl)
  hence "P  Class C⌊⌉ <* Class Object⌊⌉"
    by(rule widen1_rtrancl_into_Array_widen1_rtrancl) simp
  thus ?case by(rule rtrancl_into_trancl1) simp
next
  case (Array A)
  from ‹is_type P (A⌊⌉⌊⌉) have "is_type P (A⌊⌉)" by(rule is_type_ArrayD)
  hence "P  A⌊⌉ <+ Class Object" by(rule Array.IH)
  moreover from ‹is_type P (A⌊⌉⌊⌉) have "¬ is_NT_Array (A⌊⌉)" by auto
  ultimately have "P  A⌊⌉⌊⌉ <+ Class Object⌊⌉"
    by(rule widen1_trancl_into_Array_widen1_trancl)
  thus ?case by(rule trancl_into_trancl) simp
qed auto

lemma widen_into_widen1_trancl:
  assumes wf: "wf_prog wfmd P"
  shows " P  A  B; A  B; A  NT; is_type P A   P  A <+ B"
proof(induct rule: widen.induct)
  case (widen_subcls C D)
  from ‹Class C  Class D P  C * D have "(subcls1 P)++ C D"
    by(auto elim: rtranclp.cases intro: rtranclp_into_tranclp1)
  thus ?case by(rule subcls1_trancl_widen1_trancl)
next
  case widen_array_object thus ?case by(auto intro: Array_Object_widen1_trancl[OF wf])
next
  case (widen_array_array A B)
  hence "P  A <+ B" by(cases A) auto
  with ‹is_type P (A⌊⌉) show ?case by(auto intro: widen1_trancl_into_Array_widen1_trancl)
qed(auto)

lemma wf_prog_impl_acc_widen:
  assumes wfP: "wf_prog wfmd P"
  shows "acc (types P) (widen P)"
proof -
  from wf_converse_widen1[OF wfP]
  have "wf (((widen1 P)^-1)^+)" by(rule wf_trancl)

  hence wfw1t: "M T. T  M  (zM. y. (y, z)  ((widen1 P)¯)+  y  M)"
    by(auto simp only: wf_eq_minimal)
  have "wf {(y, x). is_type P x  is_type P y  widen P x y  x  y}"
    unfolding wf_eq_minimal
  proof(intro strip)
    fix M and T :: ty
    assume TM: "T  M"
    show "zM. y. (y, z)  {(y, T). is_type P T  is_type P y  widen P T y  T  y}  y  M"
    proof(cases "(C. Class C  M  is_class P C)  (U. U⌊⌉  M  is_type P (U⌊⌉))")
      case True
      have BNTthesis: "B.  B  (M  types P) - {NT}   ?thesis"
      proof -
        fix B
        assume BM: "B  M  types P - {NT}"
        from wfw1t[OF BM] obtain z
          where zM: "z  M"
          and znnt: "z  NT"
          and itz: "is_type P z"
          and y: "y. (y, z)  ((widen1 P)¯)+  y  M  types P - {NT}" by blast
        show "?thesis B"
        proof(rule bexI[OF _ zM], rule allI, rule impI)
          fix y
          assume "(y, z)  {(y, T). is_type P T  is_type P y  widen P T y  T  y}"
          hence Pzy: "P  z  y" and zy: "z  y" and "is_type P y" by auto
          hence "P  z <+ y" using znnt itz
            by -(rule widen_into_widen1_trancl[OF wfP])
          hence ynM: "y  M  types P - {NT}"
            by -(rule y, simp add: trancl_converse)
          thus "y  M" using Pzy znnt ‹is_type P y by auto
        qed
      qed
      from True show ?thesis by(fastforce intro: BNTthesis)
    next
      case False
      
      hence not_is_class: "C. Class C  M  ¬ is_class P C"
        and not_is_array: "U. U⌊⌉  M  ¬ is_type P (U⌊⌉)" by simp_all

      show ?thesis
      proof(cases "C. Class C  M")
        case True
        then obtain C where "Class C  M" ..
        with not_is_class[of C] show ?thesis
          by(blast dest: rtranclpD subcls_is_class Class_widen)
      next
        case False
        show ?thesis
        proof(cases "T. Array T  M")
          case True
          then obtain U where U: "Array U  M" ..
          hence "¬ is_type P (U⌊⌉)" by(rule not_is_array)
          thus ?thesis using U by(auto simp del: is_type.simps)
        next
          case False
          with ¬ (C. Class C  M) TM
          have "y. P  T  y  T  y  y  M"
            by(cases T)(fastforce simp add: NT_widen)+
          thus ?thesis using TM by blast
        qed
      qed
    qed
  qed
  thus ?thesis by(simp add: Semilat.acc_def lesssub_def lesub_def)
qed

lemmas wf_widen_acc = wf_prog_impl_acc_widen
declare wf_widen_acc [intro, simp]

lemma acyclic_widen1:
  "wf_prog wfmc P  acyclic (widen1 P)"
by(auto dest: wf_converse_widen1 wf_acyclic simp add: acyclic_converse)

lemma widen1_into_widen:
  "(A, B)  widen1 P  P  A  B"
by(induct rule: widen1.induct)(auto intro: widen.intros)

lemma widen1_rtrancl_into_widen:
  "P  A <* B  P  A  B"
by(induct rule: rtrancl_induct)(auto dest!: widen1_into_widen elim: widen_trans)

lemma widen_eq_widen1_trancl:
  " wf_prog wf_md P; T  NT; T  U; is_type P T   P  T  U  P  T <+ U"
by(blast intro: widen_into_widen1_trancl widen1_rtrancl_into_widen trancl_into_rtrancl)

lemma sup_is_type:
  assumes wf: "wf_prog wf_md P"
  and itA: "is_type P A"
  and itB: "is_type P B"
  and sup: "sup P A B = OK T"
  shows "is_type P T"
proof -
  { assume ANT: "A  NT"
      and BNT: "B  NT"
      and AnB: "A  B"
      and RTA: "is_refT A"
      and RTB: "is_refT B"
    with itA itB have AObject: "P  A  Class Object"
      and BObject: "P  B  Class Object"
      by(auto intro: is_refType_widen_Object[OF wf])
    have "is_type P (exec_lub (widen1 P) (super P) A B)"
    proof(cases "A = Class Object  B = Class Object")
      case True
      hence "exec_lub (widen1 P) (super P) A B = Class Object"
      proof(rule disjE)
        assume A: "A = Class Object"
        moreover
        from BObject BNT itB have "P  B <* Class Object"
          by(cases "B = Class Object")(auto intro: trancl_into_rtrancl widen_into_widen1_trancl[OF wf])
        hence "is_ub ((widen1 P)*) (Class Object) B (Class Object)"
          by(auto intro: is_ubI)
        hence "is_lub ((widen1 P)*) (Class Object) B (Class Object)"
          by(auto simp add: is_lub_def dest: is_ubD)
        with acyclic_widen1[OF wf]
        have "exec_lub (widen1 P) (super P) (Class Object) B = Class Object"
          by(auto intro: exec_lub_conv superI)
        ultimately show "exec_lub (widen1 P) (super P) A B = Class Object" by simp
      next
        assume B: "B = Class Object"
        moreover
        from AObject ANT itA
        have "(A, Class Object)  (widen1 P)*"
          by(cases "A = Class Object", auto intro: trancl_into_rtrancl widen_into_widen1_trancl[OF wf])
        hence "is_ub ((widen1 P)*) (Class Object) A (Class Object)"
          by(auto intro: is_ubI)
        hence "is_lub ((widen1 P)*) (Class Object) A (Class Object)"
          by(auto simp add: is_lub_def dest: is_ubD)
        with acyclic_widen1[OF wf]
        have "exec_lub (widen1 P) (super P) A (Class Object) = Class Object"
          by(auto intro: exec_lub_conv superI)
        ultimately show "exec_lub (widen1 P) (super P) A B = Class Object" by simp
      qed
      with wf show ?thesis by(simp)
    next
      case False
      hence AnObject: "A  Class Object"
        and BnObject: "B  Class Object" by auto
      from widen_into_widen1_trancl[OF wf AObject AnObject ANT itA]
      have "P  A <* Class Object" by(rule trancl_into_rtrancl)
      moreover from widen_into_widen1_trancl[OF wf BObject BnObject BNT itB]
      have "P  B <* Class Object" by(rule trancl_into_rtrancl)
      ultimately have "is_lub ((widen1 P)*) A B (exec_lub (widen1 P) (super P) A B)"
        by(rule is_lub_exec_lub[OF single_valued_widen1[OF wf] acyclic_widen1[OF wf]])(auto intro: superI)
      hence Aew1: "P  A <* exec_lub (widen1 P) (super P) A B"
        by(auto simp add: is_lub_def dest!: is_ubD)
      thus ?thesis
      proof(rule rtranclE)
        assume "A = exec_lub (widen1 P) (super P) A B"
        with itA show ?thesis by simp
      next
        fix A'
        assume "P  A' <1 exec_lub (widen1 P) (super P) A B"
        thus ?thesis by(rule widen1_is_type[OF wf])
      qed
    qed }
  with is_class_Object[OF wf] sup itA itB show ?thesis unfolding sup_def
    by(cases "A = B")(auto split: if_split_asm simp add: exec_lub_refl)
qed

lemma closed_err_types:
  assumes wfP: "wf_prog wf_mb P"
  shows "closed (err (types P)) (lift2 (sup P))"
proof -
  { fix A B
    assume it: "is_type P A" "is_type P B"
      and "A  NT" "B  NT" "A  B"
      and "is_refT A" "is_refT B"
    hence "is_type P (exec_lub (widen1 P) (super P) A B)"
      using sup_is_type[OF wfP it] by(simp add: sup_def) }
  with is_class_Object[OF wfP] show ?thesis
    unfolding closed_def plussub_def lift2_def sup_def'
    by(auto split: err.split ty.splits)(auto simp add: exec_lub_refl)
qed

lemma widen_into_widen1_rtrancl:
  "wf_prog wfmd P; widen P A B; A  NT; is_type P A   (A, B)  (widen1 P)*"
by(cases "A = B")(auto intro: trancl_into_rtrancl widen_into_widen1_trancl)


lemma sup_widen_greater:
  assumes wfP: "wf_prog wf_mb P"
  and it1: "is_type P t1"
  and it2: "is_type P t2"
  and sup: "sup P t1 t2 = OK s"
  shows "widen P t1 s  widen P t2 s"
proof -
  { assume t1: "is_refT t1"
      and t2: "is_refT t2"
      and t1NT: "t1  NT"
      and t2NT: "t2  NT"
    with it1 it2 wfP have "P  t1  Class Object" "P  t2  Class Object"
      by(auto intro: is_refType_widen_Object)
    with t1NT t2NT it1 it2
    have "P  t1 <* Class Object" "P  t2 <* Class Object"
      by(auto intro: widen_into_widen1_rtrancl[OF wfP])
    with single_valued_widen1[OF wfP]
    obtain u where "is_lub ((widen1 P)^*) t1 t2 u" 
      by (blast dest: single_valued_has_lubs)
    hence "P  t1  exec_lub (widen1 P) (super P) t1 t2 
           P  t2  exec_lub (widen1 P) (super P) t1 t2"
      using acyclic_widen1[OF wfP] superI[of _ _ P]
      by(simp add: exec_lub_conv)(blast dest: is_lubD is_ubD intro: widen1_rtrancl_into_widen) }
  with it1 it2 sup show ?thesis
    by (cases s) (auto simp add: sup_def split: if_split_asm elim: refTE)
qed

lemma sup_widen_smallest:
  assumes wfP: "wf_prog wf_mb P"
  and itT: "is_type P T"
  and itU: "is_type P U"
  and TwV: "P  T  V"
  and UwV: "P  U  V"
  and sup: "sup P T U = OK W"
  shows "widen P W V"
proof -
  { assume rT: "is_refT T"
      and rU: "is_refT U"
      and UNT: "U  NT"
      and TNT: "T  NT"
      and W: "exec_lub (widen1 P) (super P) T U = W"
    from itU itT rT rU UNT TNT have "P  T  Class Object" "P  U  Class Object"
      by(auto intro:is_refType_widen_Object[OF wfP])
    with UNT TNT itT itU
    have "P  T <* Class Object" "P  U <* Class Object"
      by(auto intro: widen_into_widen1_rtrancl[OF wfP])
    with single_valued_widen1[OF wfP]
    obtain X where lub: "is_lub ((widen1 P)^* ) T U X"
      by (blast dest: single_valued_has_lubs)   
    with acyclic_widen1[OF wfP]
    have "exec_lub (widen1 P) (super P) T U = X"
      by (blast intro: superI exec_lub_conv)
    also from TwV TNT UwV UNT itT itU have "P  T <* V" "P  U <* V"
      by(auto intro: widen_into_widen1_rtrancl[OF wfP])
    with lub have "P  X <* V"
      by (clarsimp simp add: is_lub_def is_ub_def)
    finally have "P  exec_lub (widen1 P) (super P) T U  V"
      by(rule widen1_rtrancl_into_widen)
    with W have "P  W  V" by simp }
  with sup itT itU TwV UwV show ?thesis
    by(simp add: sup_def split: if_split_asm)
qed

lemma sup_exists:
  " widen P a c; widen P b c   T. sup P a b = OK T"
by(cases b a rule: ty.exhaust[case_product ty.exhaust])(auto simp add: sup_def)

lemma err_semilat_JType_esl:
  assumes wf_prog: "wf_prog wf_mb P"
  shows "err_semilat (esl P)"
proof -
  from wf_prog have "order (widen P)" ..
  moreover from wf_prog
  have "closed (err (types P)) (lift2 (sup P))"
    by (rule closed_err_types)
  moreover
  from wf_prog have
    "(xerr (types P). yerr (types P). xErr.le (widen P) xlift2 (sup P) y)  
     (xerr (types P). yerr (types P). yErr.le (widen P) xlift2 (sup P) y)"
    by(auto simp add: lesub_def plussub_def Err.le_def lift2_def sup_widen_greater split: err.split)
  moreover from wf_prog have
    "xerr (types P). yerr (types P). zerr (types P). 
    xErr.le (widen P) z  yErr.le (widen P) z  xlift2 (sup P) yErr.le (widen P) z"
    unfolding lift2_def plussub_def lesub_def Err.le_def
    by(auto intro: sup_widen_smallest dest:sup_exists simp add: split: err.split)
  ultimately show ?thesis by (simp add: esl_def semilat_def sl_def Err.sl_def)
qed

subsection ‹Relation between @{term "sup P T U = OK V"} and @{term "P  lub(T, U) = V"}

lemma sup_is_lubI:
  assumes wf: "wf_prog wf_md P"
  and it: "is_type P T" "is_type P U"
  and sup: "sup P T U = OK V"
  shows "P  lub(T, U) = V"
proof 
  from sup_widen_greater[OF wf it sup]
  show "P  T  V" "P  U  V" by blast+
next
  fix T'
  assume "P  T  T'" "P  U  T'"
  thus "P  V  T'" using sup by(rule sup_widen_smallest[OF wf it])
qed

lemma is_lub_subD:
  assumes wf: "wf_prog wf_md P"
  and it: "is_type P T" "is_type P U"
  and lub: "P  lub(T, U) = V"
  shows "sup P T U = OK V"
proof -
  from lub have "P  T  V" "P  U  V" by(blast dest: is_lub_upper)+
  from sup_exists[OF this] obtain W where "sup P T U = OK W" by blast
  moreover
  with wf it have "P  lub(T, U) = W" by(rule sup_is_lubI)
  with lub have "V = W" by(auto dest: is_lub_unique[OF wf])
  ultimately show ?thesis by simp
qed

lemma is_lub_is_type:
  " wf_prog wf_md P; is_type P T; is_type P U; P  lub(T, U) = V   is_type P V"
by(frule (3) is_lub_subD)(erule (3) sup_is_type)

subsection ‹Code generator setup›

code_pred widen1p .
lemmas [code] = widen1_def

lemma eval_widen1p_i_i_o_conv:
  "Predicate.eval (widen1p_i_i_o P T) = (λU. P  T <1 U)"
by(auto elim: widen1p_i_i_oE intro: widen1p_i_i_oI simp add: widen1_def fun_eq_iff)

lemma rtrancl_widen1_code [code_unfold]:
  "(widen1 P)^* = {(a, b). Predicate.holds (rtrancl_tab_FioB_i_i_i (widen1p_i_i_o P) [] a b)}"
by(auto simp add: fun_eq_iff Predicate.holds_eq widen1_def rtrancl_def rtranclp_eq_rtrancl_tab_nil eval_widen1p_i_i_o_conv intro!: rtrancl_tab_FioB_i_i_iI elim!: rtrancl_tab_FioB_i_i_iE)

declare exec_lub_def [code_unfold]

end

Theory State

(*  Title:      JinjaThreads/J/State.thy
    Author:     Tobias Nipkow, Andreas Lochbihler
*)

chapter ‹JinjaThreads source language›

section ‹Program State›

theory State
imports
  "../Common/Heap"
begin


type_synonym
  'addr locals = "vname  'addr val"      ― ‹local vars, incl. params and ``this''›
type_synonym
  ('addr, 'heap) Jstate = "'heap × 'addr locals"     ― ‹the heap and the local vars›

definition hp :: "'heap × 'x  'heap" where "hp  fst"

definition lcl :: "'heap × 'x  'x" where "lcl  snd"

lemma hp_conv [simp]: "hp (h, l) = h"
by(simp add: hp_def)

lemma lcl_conv [simp]: "lcl (h, l) = l"
by(simp add: lcl_def)

end

Theory Expr

(*  Title:      JinjaThreads/J/Expr.thy
    Author:     Tobias Nipkow, Andreas Lochbihler
*)

section ‹Expressions›

theory Expr
imports
  "../Common/BinOp"
begin

datatype (dead 'a, dead 'b, dead 'addr) exp
  = new cname      ― ‹class instance creation›
  | newArray ty "('a,'b,'addr) exp" ("newA __" [99,0] 90)    ― ‹array instance creation: type, size in outermost dimension›
  | Cast ty "('a,'b,'addr) exp"      ― ‹type cast›
  | InstanceOf "('a,'b,'addr) exp" ty ("_ instanceof _" [99, 99] 90) ― ‹instance of›
  | Val "'addr val"      ― ‹value›
  | BinOp "('a,'b,'addr) exp" bop "('a,'b,'addr) exp"     ("_ «_» _" [80,0,81] 80)      ― ‹binary operation›
  | Var 'a                                               ― ‹local variable (incl. parameter)›
  | LAss 'a "('a,'b,'addr) exp"            ("_:=_" [90,90]90)                    ― ‹local assignment›
  | AAcc "('a,'b,'addr) exp" "('a,'b,'addr) exp"            ("__" [99,0] 90)          ― ‹array cell read›
  | AAss "('a,'b,'addr) exp" "('a,'b,'addr) exp" "('a,'b,'addr) exp" ("__ := _" [10,99,90] 90)    ― ‹array cell assignment›
  | ALen "('a,'b,'addr) exp"                 ("_∙length" [10] 90)          ― ‹array length›
  | FAcc "('a,'b,'addr) exp" vname cname     ("__{_}" [10,90,99]90)       ― ‹field access›
  | FAss "('a,'b,'addr) exp" vname cname "('a,'b,'addr) exp"     ("__{_} := _" [10,90,99,90]90)      ― ‹field assignment›
  | CompareAndSwap "('a,'b,'addr) exp" cname vname "('a,'b,'addr) exp" "('a,'b,'addr) exp" ("_∙compareAndSwap('(__, _, _'))" [10,90,90,90,90] 90) ― ‹compare and swap›
  | Call "('a,'b,'addr) exp" mname "('a,'b,'addr) exp list"     ("__'(_')" [90,99,0] 90)            ― ‹method call›
  | Block 'a ty "'addr val option" "('a,'b,'addr) exp"    ("'{_:_=_; _}")
  | Synchronized 'b "('a,'b,'addr) exp" "('a,'b,'addr) exp" ("sync⇘_ '(_') _" [99,99,90] 90)
  | InSynchronized 'b 'addr "('a,'b,'addr) exp" ("insync⇘_ '(_') _" [99,99,90] 90)
  | Seq "('a,'b,'addr) exp" "('a,'b,'addr) exp"     ("_;;/ _"             [61,60]60)
  | Cond "('a,'b,'addr) exp" "('a,'b,'addr) exp" "('a,'b,'addr) exp"     ("if '(_') _/ else _" [80,79,79]70)
  | While "('a,'b,'addr) exp" "('a,'b,'addr) exp"     ("while '(_') _"     [80,79]70)
  | throw "('a,'b,'addr) exp"
  | TryCatch "('a,'b,'addr) exp" cname 'a "('a,'b,'addr) exp"     ("try _/ catch'(_ _') _"  [0,99,80,79] 70)

type_synonym
  'addr expr = "(vname, unit, 'addr) exp"    ― ‹Jinja expression›
type_synonym
  'addr J_mb = "vname list × 'addr expr"    ― ‹Jinja method body: parameter names and expression›
type_synonym
  'addr J_prog = "'addr J_mb prog"          ― ‹Jinja program›

translations
  (type) "'addr expr" <= (type) "(String.literal, unit, 'addr) exp"
  (type) "'addr J_prog" <= (type) "(String.literal list × 'addr expr) prog"

subsection "Syntactic sugar"

abbreviation unit :: "('a,'b,'addr) exp"
where "unit  Val Unit"

abbreviation null :: "('a,'b,'addr) exp"
where "null  Val Null"

abbreviation addr :: "'addr  ('a,'b,'addr) exp"
where "addr a == Val (Addr a)"

abbreviation true :: "('a,'b,'addr) exp"
where "true == Val (Bool True)"

abbreviation false :: "('a,'b,'addr) exp"
where "false == Val (Bool False)"

abbreviation Throw :: "'addr  ('a,'b,'addr) exp"
where "Throw a == throw (Val (Addr a))"

abbreviation (in heap_base) THROW :: "cname  ('a,'b,'addr) exp"
where "THROW xc == Throw (addr_of_sys_xcpt xc)"

abbreviation sync_unit_syntax :: "('a,unit,'addr) exp  ('a,unit,'addr) exp  ('a,unit,'addr) exp" ("sync'(_') _" [99,90] 90)
where "sync(e1) e2  sync() (e1) e2"

abbreviation insync_unit_syntax :: "'addr  ('a,unit,'addr) exp  ('a,unit,'addr) exp" ("insync'(_') _" [99,90] 90)
where "insync(a) e2  insync() (a) e2"

text ‹Java syntax for binary operators›

abbreviation BinOp_Eq :: "('a, 'b, 'c) exp  ('a, 'b, 'c) exp  ('a, 'b, 'c) exp"
  ("_ «==» _" [80,81] 80)
where "e «==» e'  e «Eq» e'"

abbreviation BinOp_NotEq :: "('a, 'b, 'c) exp  ('a, 'b, 'c) exp  ('a, 'b, 'c) exp"
   ("_ «!=» _" [80,81] 80)
where "e «!=» e'  e «NotEq» e'"

abbreviation BinOp_LessThan :: "('a, 'b, 'c) exp  ('a, 'b, 'c) exp  ('a, 'b, 'c) exp"
   ("_ «<» _" [80,81] 80)
where "e «<» e'  e «LessThan» e'"

abbreviation BinOp_LessOrEqual :: "('a, 'b, 'c) exp  ('a, 'b, 'c) exp  ('a, 'b, 'c) exp"
   ("_ «<=» _" [80,81] 80)
where "e «<=» e'  e «LessOrEqual» e'"

abbreviation BinOp_GreaterThan :: "('a, 'b, 'c) exp  ('a, 'b, 'c) exp  ('a, 'b, 'c) exp"
   ("_ «>» _" [80,81] 80)
where "e «>» e'  e «GreaterThan» e'"

abbreviation BinOp_GreaterOrEqual :: "('a, 'b, 'c) exp  ('a, 'b, 'c) exp  ('a, 'b, 'c) exp"
   ("_ «>=» _" [80,81] 80)
where "e «>=» e'  e «GreaterOrEqual» e'"

abbreviation BinOp_Add :: "('a, 'b, 'c) exp  ('a, 'b, 'c) exp  ('a, 'b, 'c) exp"
   ("_ «+» _" [80,81] 80)
where "e «+» e'  e «Add» e'"

abbreviation BinOp_Subtract :: "('a, 'b, 'c) exp  ('a, 'b, 'c) exp  ('a, 'b, 'c) exp"
   ("_ «-» _" [80,81] 80)
where "e «-» e'  e «Subtract» e'"

abbreviation BinOp_Mult :: "('a, 'b, 'c) exp  ('a, 'b, 'c) exp  ('a, 'b, 'c) exp"
   ("_ «*» _" [80,81] 80)
where "e «*» e'  e «Mult» e'"

abbreviation BinOp_Div :: "('a, 'b, 'c) exp  ('a, 'b, 'c) exp  ('a, 'b, 'c) exp"
   ("_ «'/» _" [80,81] 80)
where "e «/» e'  e «Div» e'"

abbreviation BinOp_Mod :: "('a, 'b, 'c) exp  ('a, 'b, 'c) exp  ('a, 'b, 'c) exp"
   ("_ «%» _" [80,81] 80)
where "e «%» e'  e «Mod» e'"

abbreviation BinOp_BinAnd :: "('a, 'b, 'c) exp  ('a, 'b, 'c) exp  ('a, 'b, 'c) exp"
   ("_ «&» _" [80,81] 80)
where "e «&» e'  e «BinAnd» e'"

abbreviation BinOp_BinOr :: "('a, 'b, 'c) exp  ('a, 'b, 'c) exp  ('a, 'b, 'c) exp"
   ("_ «|» _" [80,81] 80)
where "e «|» e'  e «BinOr» e'"

abbreviation BinOp_BinXor :: "('a, 'b, 'c) exp  ('a, 'b, 'c) exp  ('a, 'b, 'c) exp"
   ("_ «^» _" [80,81] 80)
where "e «^» e'  e «BinXor» e'"

abbreviation BinOp_ShiftLeft :: "('a, 'b, 'c) exp  ('a, 'b, 'c) exp  ('a, 'b, 'c) exp"
   ("_ «<<» _" [80,81] 80)
where "e «<<» e'  e «ShiftLeft» e'"

abbreviation BinOp_ShiftRightZeros :: "('a, 'b, 'c) exp  ('a, 'b, 'c) exp  ('a, 'b, 'c) exp"
   ("_ «>>>» _" [80,81] 80)
where "e «>>>» e'  e «ShiftRightZeros» e'"

abbreviation BinOp_ShiftRightSigned :: "('a, 'b, 'c) exp  ('a, 'b, 'c) exp  ('a, 'b, 'c) exp"
   ("_ «>>» _" [80,81] 80)
where "e «>>» e'  e «ShiftRightSigned» e'"

abbreviation BinOp_CondAnd :: "('a, 'b, 'c) exp  ('a, 'b, 'c) exp  ('a, 'b, 'c) exp"
   ("_ «&&» _" [80,81] 80)
where "e «&&» e'  if (e) e' else false"

abbreviation BinOp_CondOr :: "('a, 'b, 'c) exp  ('a, 'b, 'c) exp  ('a, 'b, 'c) exp"
   ("_ «||» _" [80,81] 80)
where "e «||» e'  if (e) true else e'"

lemma inj_Val [simp]: "inj Val"
by(rule inj_onI)(simp)

lemma expr_ineqs [simp]: "Val v ;; e  e" "if (e1) e else e2  e" "if (e1) e2 else e  e"
by(induct e) auto

subsection‹Free Variables›

primrec fv  :: "('a,'b,'addr) exp       'a set"
  and fvs :: "('a,'b,'addr) exp list  'a set"
where
  "fv(new C) = {}"
| "fv(newA Te) = fv e"
| "fv(Cast C e) = fv e"
| "fv(e instanceof T) = fv e"
| "fv(Val v) = {}"
| "fv(e1 «bop» e2) = fv e1  fv e2"
| "fv(Var V) = {V}"
| "fv(ai) = fv a  fv i"
| "fv(AAss a i e) = fv a  fv i  fv e"
| "fv(a∙length) = fv a"
| "fv(LAss V e) = {V}  fv e"
| "fv(eF{D}) = fv e"
| "fv(FAss e1 F D e2) = fv e1  fv e2"
| "fv(e1∙compareAndSwap(DF, e2, e3)) = fv e1  fv e2  fv e3"
| "fv(eM(es)) = fv e  fvs es"
| "fv({V:T=vo; e}) = fv e - {V}"
| "fv(syncV (h) e) = fv h  fv e"
| "fv(insyncV (a) e) = fv e"
| "fv(e1;;e2) = fv e1  fv e2"
| "fv(if (b) e1 else e2) = fv b  fv e1  fv e2"
| "fv(while (b) e) = fv b  fv e"
| "fv(throw e) = fv e"
| "fv(try e1 catch(C V) e2) = fv e1  (fv e2 - {V})"

| "fvs([]) = {}"
| "fvs(e#es) = fv e  fvs es"

lemma [simp]: "fvs(es @ es') = fvs es  fvs es'"
by(induct es) auto

lemma [simp]: "fvs(map Val vs) = {}"
by (induct vs) auto

subsection‹Locks and addresses›

primrec expr_locks :: "('a,'b,'addr) exp  'addr  nat"
  and expr_lockss :: "('a,'b,'addr) exp list  'addr  nat"
where
  "expr_locks (new C) = (λad. 0)"
| "expr_locks (newA Te) = expr_locks e"
| "expr_locks (Cast T e) = expr_locks e"
| "expr_locks (e instanceof T) = expr_locks e"
| "expr_locks (Val v) = (λad. 0)"
| "expr_locks (Var v) = (λad. 0)"
| "expr_locks (e «bop» e') = (λad. expr_locks e ad + expr_locks e' ad)"
| "expr_locks (V := e) = expr_locks e"
| "expr_locks (ai) = (λad. expr_locks a ad + expr_locks i ad)"
| "expr_locks (AAss a i e) = (λad. expr_locks a ad + expr_locks i ad + expr_locks e ad)"
| "expr_locks (a∙length) = expr_locks a"
| "expr_locks (eF{D}) = expr_locks e"
| "expr_locks (FAss e F D e') = (λad. expr_locks e ad + expr_locks e' ad)"
| "expr_locks (e∙compareAndSwap(DF, e', e'')) = (λad. expr_locks e ad + expr_locks e' ad + expr_locks e'' ad)"
| "expr_locks (em(ps)) = (λad. expr_locks e ad + expr_lockss ps ad)"
| "expr_locks ({V : T=vo; e}) = expr_locks e"
| "expr_locks (syncV (o') e) = (λad. expr_locks o' ad + expr_locks e ad)"
| "expr_locks (insyncV (a) e) = (λad. if (a = ad) then Suc (expr_locks e ad) else expr_locks e ad)"
| "expr_locks (e;;e') = (λad. expr_locks e ad + expr_locks e' ad)"
| "expr_locks (if (b) e else e') = (λad. expr_locks b ad + expr_locks e ad + expr_locks e' ad)"
| "expr_locks (while (b) e) = (λad. expr_locks b ad + expr_locks e ad)"
| "expr_locks (throw e) = expr_locks e"
| "expr_locks (try e catch(C v) e') = (λad. expr_locks e ad + expr_locks e' ad)"

| "expr_lockss [] = (λa. 0)"
| "expr_lockss (x#xs) = (λad. expr_locks x ad + expr_lockss xs ad)"

lemma expr_lockss_append [simp]:
  "expr_lockss (es @ es') = (λad. expr_lockss es ad + expr_lockss es' ad)"
by(induct es) auto

lemma expr_lockss_map_Val [simp]: "expr_lockss (map Val vs) = (λad. 0)"
by(induct vs) auto

primrec contains_insync :: "('a,'b,'addr) exp  bool"
  and contains_insyncs :: "('a,'b,'addr) exp list  bool"
where
  "contains_insync (new C) = False"
| "contains_insync (newA Ti) = contains_insync i"
| "contains_insync (Cast T e) = contains_insync e"
| "contains_insync (e instanceof T) = contains_insync e"
| "contains_insync (Val v) = False"
| "contains_insync (Var v) = False"
| "contains_insync (e «bop» e') = (contains_insync e  contains_insync e')"
| "contains_insync (V := e) = contains_insync e"
| "contains_insync (ai) = (contains_insync a  contains_insync i)"
| "contains_insync (AAss a i e) = (contains_insync a  contains_insync i  contains_insync e)"
| "contains_insync (a∙length) = contains_insync a"
| "contains_insync (eF{D}) = contains_insync e"
| "contains_insync (FAss e F D e') = (contains_insync e  contains_insync e')"
| "contains_insync (e∙compareAndSwap(DF, e', e'')) = (contains_insync e  contains_insync e'  contains_insync e'')"
| "contains_insync (em(pns)) = (contains_insync e  contains_insyncs pns)"
| "contains_insync ({V : T=vo; e}) = contains_insync e"
| "contains_insync (syncV (o') e) = (contains_insync o'  contains_insync e)"
| "contains_insync (insyncV (a) e) = True"
| "contains_insync (e;;e') = (contains_insync e  contains_insync e')"
| "contains_insync (if (b) e else e') = (contains_insync b  contains_insync e  contains_insync e')"
| "contains_insync (while (b) e) = (contains_insync b  contains_insync e)"
| "contains_insync (throw e) = contains_insync e"
| "contains_insync (try e catch(C v) e') = (contains_insync e  contains_insync e')"

| "contains_insyncs [] = False"
| "contains_insyncs (x # xs) = (contains_insync x  contains_insyncs xs)"
  
lemma contains_insyncs_append [simp]:
  "contains_insyncs (es @ es')  contains_insyncs es  contains_insyncs es'"
by(induct es, auto)

lemma fixes e :: "('a, 'b, 'addr) exp"
  and es :: "('a, 'b, 'addr) exp list"
  shows contains_insync_conv: "(contains_insync e  (ad. expr_locks e ad > 0))"
    and contains_insyncs_conv: "(contains_insyncs es  (ad. expr_lockss es ad > 0))"
by(induct e and es rule: expr_locks.induct expr_lockss.induct)(auto)

lemma contains_insyncs_map_Val [simp]: "¬ contains_insyncs (map Val vs)"
by(induct vs) auto

subsection ‹Value expressions›

inductive is_val :: "('a,'b,'addr) exp  bool" where
  "is_val (Val v)"

declare is_val.intros [simp]
declare is_val.cases [elim!]

lemma is_val_iff: "is_val e  (v. e = Val v)"
by(auto)

code_pred is_val .

fun is_vals :: "('a,'b,'addr) exp list  bool" where
  "is_vals [] = True"
| "is_vals (e#es) = (is_val e  is_vals es)"

lemma is_vals_append [simp]: "is_vals (es @ es')  is_vals es  is_vals es'"
by(induct es) auto

lemma is_vals_conv: "is_vals es = (vs. es = map Val vs)"
by(induct es)(auto simp add: Cons_eq_map_conv)

lemma is_vals_map_Vals [simp]: "is_vals (map Val vs) = True"
unfolding is_vals_conv by auto

inductive is_addr :: "('a,'b,'addr) exp  bool"
where "is_addr (addr a)"

declare is_addr.intros[intro!]
declare is_addr.cases[elim!]

lemma [simp]: "(is_addr e)  (a. e = addr a)"
by auto

primrec the_Val :: "('a, 'b, 'addr) exp  'addr val"
where
  "the_Val (Val v) = v"

inductive is_Throws :: "('a, 'b, 'addr) exp list  bool"
where
  "is_Throws (Throw a # es)"
| "is_Throws es  is_Throws (Val v # es)"

inductive_simps is_Throws_simps:
  "is_Throws []"
  "is_Throws (e # es)"

code_pred is_Throws .

lemma is_Throws_conv: "is_Throws es  (vs a es'. es = map Val vs @ Throw a # es')"
  (is "?lhs  ?rhs")
proof
  assume ?lhs thus ?rhs
    by(induct)(fastforce simp add: Cons_eq_append_conv Cons_eq_map_conv)+
next
  assume ?rhs thus ?lhs
    by(induct es)(auto simp add: is_Throws_simps Cons_eq_map_conv Cons_eq_append_conv)
qed

subsection blocks›

fun blocks :: "'a list  ty list  'addr val list  ('a,'b,'addr) exp  ('a,'b,'addr) exp"
where
  "blocks (V # Vs) (T # Ts) (v # vs) e = {V:T=v; blocks Vs Ts vs e}"
| "blocks []       []       []       e = e"

lemma [simp]:
  " size vs = size Vs; size Ts = size Vs   fv (blocks Vs Ts vs e) = fv e - set Vs"
by(induct rule:blocks.induct)(simp_all, blast)

lemma expr_locks_blocks:
  " length vs = length pns; length Ts = length pns 
   expr_locks (blocks pns Ts vs e) = expr_locks e"
by(induct pns Ts vs e rule: blocks.induct)(auto)

subsection ‹Final expressions›

inductive final :: "('a,'b,'addr) exp  bool" where
  "final (Val v)"
| "final (Throw a)"

declare final.cases [elim]
declare final.intros[simp]

lemmas finalE[consumes 1, case_names Val Throw] = final.cases

lemma final_iff: "final e  (v. e = Val v)  (a. e = Throw a)"
by(auto)

lemma final_locks: "final e  expr_locks e l = 0"
by(auto elim: finalE)

inductive finals :: "('a,'b,'addr) exp list  bool"
where
  "finals []"
| "finals (Throw a # es)"
| "finals es  finals (Val v # es)"

inductive_simps finals_simps:
  "finals (e # es)"

lemma [iff]: "finals []"
by(rule finals.intros)

lemma [iff]: "finals (Val v # es) = finals es"
by(simp add: finals_simps)

lemma finals_app_map [iff]: "finals (map Val vs @ es) = finals es"
by(induct vs) simp_all

lemma [iff]: "finals (throw e # es) = (a. e = addr a)"
by(simp add: finals_simps)

lemma not_finals_ConsI: "¬ final e  ¬ finals (e # es)"
by(simp add: finals_simps final_iff)

lemma finals_iff: "finals es  (vs. es = map Val vs)  (vs a es'. es = map Val vs @ Throw a # es')"
  (is "?lhs  ?rhs")
proof
  assume ?lhs thus ?rhs
    by induct(auto simp add: Cons_eq_append_conv Cons_eq_map_conv, metis)
next
  assume ?rhs thus ?lhs by(induct es) auto
qed

code_pred final .

subsection ‹converting results from external calls›

primrec extRet2J :: "('a, 'b, 'addr) exp  'addr extCallRet  ('a, 'b, 'addr) exp"
where
  "extRet2J e (RetVal v) = Val v"
| "extRet2J e (RetExc a) = Throw a"
| "extRet2J e RetStaySame = e"

lemma fv_extRet2J [simp]: "fv (extRet2J e va)  fv e"
by(cases va) simp_all

subsection ‹expressions at a call›

primrec call :: "('a,'b,'addr) exp  ('addr × mname × 'addr val list) option"
  and calls :: "('a,'b,'addr) exp list  ('addr × mname × 'addr val list) option"
where
  "call (new C) = None"
| "call (newA Te) = call e"
| "call (Cast C e) = call e"
| "call (e instanceof T) = call e"
| "call (Val v) = None"
| "call (Var V) = None"
| "call (V:=e) = call e"
| "call (e «bop» e') = (if is_val e then call e' else call e)"
| "call (ai) = (if is_val a then call i else call a)"
| "call (AAss a i e) = (if is_val a then (if is_val i then call e else call i) else call a)"
| "call (a∙length) = call a"
| "call (eF{D}) = call e"
| "call (FAss e F D e') = (if is_val e then call e' else call e)"
| "call (e∙compareAndSwap(DF, e', e'')) = (if is_val e then if is_val e' then call e'' else call e' else call e)"
| "call (eM(es)) = (if is_val e then
                     (if is_vals es  is_addr e then (THE a. e = addr a, M, THE vs. es = map Val vs) else calls es) 
                     else call e)"
| "call ({V:T=vo; e}) = call e"
| "call (syncV (o') e) = call o'"
| "call (insyncV (a) e) = call e"
| "call (e;;e') = call e"
| "call (if (e) e1 else e2) = call e"
| "call (while(b) e) = None"
| "call (throw e) = call e"
| "call (try e1 catch(C V) e2) = call e1"

| "calls [] = None"
| "calls (e#es) = (if is_val e then calls es else call e)"

lemma calls_append [simp]:
  "calls (es @ es') = (if calls es = None  is_vals es then calls es' else calls es)"
by(induct es) auto

lemma call_callE [consumes 1, case_names CallObj CallParams Call]:
  " call (objM(pns)) = (a, M', vs);
     call obj = (a, M', vs)  thesis; 
     v.  obj = Val v; calls pns = (a, M', vs)   thesis;
      obj = addr a; pns = map Val vs; M = M'   thesis   thesis"
by(auto split: if_split_asm simp add: is_vals_conv)

lemma calls_map_Val [simp]:
  "calls (map Val vs) = None"
by(induct vs) auto

lemma call_not_is_val [dest]: "call e = aMvs  ¬ is_val e"
by(cases e) auto

lemma is_calls_not_is_vals [dest]: "calls es = aMvs  ¬ is_vals es"
by(induct es) auto

end

Theory JHeap

(*  Title:      JinjaThreads/J/JHeap.thy
    Author:     Andreas Lochbihler
*)

section ‹Abstract heap locales for source code programs›

theory JHeap
imports
  "../Common/Conform"
  Expr
begin

locale J_heap_base = heap_base +
  constrains addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"

locale J_heap = heap + 
  constrains addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and P :: "'addr J_prog"

sublocale J_heap < J_heap_base .

locale J_heap_conf_base = heap_conf_base +
  constrains addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and hconf :: "'heap  bool"
  and P :: "'addr J_prog"

sublocale J_heap_conf_base < J_heap_base .

locale J_heap_conf = 
  J_heap_conf_base +
  heap_conf +
  constrains addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and hconf :: "'heap  bool"
  and P :: "'addr J_prog"

sublocale J_heap_conf < J_heap
by(unfold_locales)

locale J_progress =
  heap_progress +
  J_heap_conf_base +
  constrains addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and hconf :: "'heap  bool"
  and P :: "'addr J_prog"

sublocale J_progress < J_heap by(unfold_locales) 

locale J_conf_read =
  heap_conf_read +
  J_heap_conf +
  constrains addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and hconf :: "'heap  bool"
  and P :: "'addr J_prog"

sublocale J_conf_read < J_heap by(unfold_locales)

locale J_typesafe =
  heap_typesafe +
  J_conf_read +
  J_progress +
  constrains addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and hconf :: "'heap  bool"
  and P :: "'addr J_prog"

end

Theory SmallStep

(*  Title:      JinjaThreads/J/SmallStep.thy
    Author:     Tobias Nipkow, Andreas Lochbihler
*)

section ‹Small Step Semantics›

theory SmallStep
imports
  Expr
  State
  JHeap
begin

type_synonym
  ('addr, 'thread_id, 'heap) J_thread_action =
  "('addr, 'thread_id, 'addr expr × 'addr locals,'heap) Jinja_thread_action"

type_synonym
  ('addr, 'thread_id, 'heap) J_state = 
  "('addr,'thread_id,'addr expr × 'addr locals,'heap,'addr) state"

(* pretty printing for J_thread_action type *)
print_translation let
    fun tr'
       [a1, t
       , Const (@{type_syntax "prod"}, _) $ 
           (Const (@{type_syntax "exp"}, _) $
              Const (@{type_syntax "String.literal"}, _) $ Const (@{type_syntax "unit"}, _) $ a2) $
           (Const (@{type_syntax "fun"}, _) $
              Const (@{type_syntax "String.literal"}, _) $
              (Const (@{type_syntax "option"}, _) $
                 (Const (@{type_syntax "val"}, _) $ a3)))
       , h] =
      if a1 = a2 andalso a2 = a3 then Syntax.const @{type_syntax "J_thread_action"} $ a1 $ t $ h
      else raise Match;
    in [(@{type_syntax "Jinja_thread_action"}, K tr')]
  end
typ "('addr,'thread_id,'heap) J_thread_action"

(* pretty printing for J_state type *)
print_translation let
    fun tr'
       [a1, t
       , Const (@{type_syntax "prod"}, _) $ 
           (Const (@{type_syntax "exp"}, _) $
              Const (@{type_syntax "String.literal"}, _) $ Const (@{type_syntax "unit"}, _) $ a2) $
           (Const (@{type_syntax "fun"}, _) $
              Const (@{type_syntax "String.literal"}, _) $
              (Const (@{type_syntax "option"}, _) $
                 (Const (@{type_syntax "val"}, _) $ a3)))
       , h, a4] =
      if a1 = a2 andalso a2 = a3 andalso a3 = a4 then Syntax.const @{type_syntax "J_state"} $ a1 $ t $ h
      else raise Match;
    in [(@{type_syntax "state"}, K tr')]
  end
typ "('addr, 'thread_id, 'heap) J_state"

definition extNTA2J :: "'addr J_prog  (cname × mname × 'addr)  'addr expr × 'addr locals"
where "extNTA2J P = (λ(C, M, a). let (D,Ts,T,meth) = method P C M; (pns,body) = the meth
                                 in ({this:Class D=Addr a; body}, Map.empty))"

abbreviation J_local_start ::
  "cname  mname  ty list  ty  'addr J_mb  'addr val list
   'addr expr × 'addr locals"
where
  "J_local_start  
  λC M Ts T (pns, body) vs. 
  (blocks (this # pns) (Class C # Ts) (Null # vs) body, Map.empty)"

abbreviation (in J_heap_base) 
  J_start_state :: "'addr J_prog  cname  mname  'addr val list  ('addr, 'thread_id, 'heap) J_state"
where
  "J_start_state  start_state J_local_start"


lemma extNTA2J_iff [simp]:
  "extNTA2J P (C, M, a) = ({this:Class (fst (method P C M))=Addr a; snd (the (snd (snd (snd (method P C M)))))}, Map.empty)"
by(simp add: extNTA2J_def split_beta)

abbreviation extTA2J :: 
  "'addr J_prog  ('addr, 'thread_id, 'heap) external_thread_action  ('addr, 'thread_id, 'heap) J_thread_action"
where "extTA2J P  convert_extTA (extNTA2J P)"

lemma extTA2J_ε: "extTA2J P ε = ε"
by(simp)

text‹Locking mechanism:
  The expression on which the thread is synchronized is evaluated first to a value.
  If this expression evaluates to null, a null pointer expression is thrown.
  If this expression evaluates to an address, a lock must be obtained on this address, the
  sync expression is rewritten to insync.
  For insync expressions, the body expression may be evaluated.
  If the body expression is only a value or a thrown exception, the lock is released and
  the synchronized expression reduces to the body's expression. This is the normal Java semantics,
  not the one as presented in LNCS 1523, Cenciarelli/Knapp/Reus/Wirsing. There
  the expression on which the thread synchronized is evaluated except for the last step.
  If the thread can obtain the lock on the object immediately after the last evaluation step, the evaluation is
  done and the lock acquired. If the lock cannot be obtained, the evaluation step is discarded. If another thread
  changes the evaluation result of this last step, the thread then will try to synchronize on the new object.›

context J_heap_base begin

inductive red :: 
  "(('addr, 'thread_id, 'heap) external_thread_action  ('addr, 'thread_id, 'x,'heap) Jinja_thread_action)
    'addr J_prog  'thread_id
    'addr expr  ('addr, 'heap) Jstate
    ('addr, 'thread_id, 'x,'heap) Jinja_thread_action
    'addr expr  ('addr, 'heap) Jstate  bool"
  ("_,_,_  ((1_,/_) -_/ (1_,/_))" [51,51,0,0,0,0,0,0] 81)
 and reds ::
  "(('addr, 'thread_id, 'heap) external_thread_action  ('addr, 'thread_id, 'x,'heap) Jinja_thread_action)
    'addr J_prog  'thread_id 
    'addr expr list  ('addr, 'heap) Jstate 
    ('addr, 'thread_id, 'x,'heap) Jinja_thread_action
    'addr expr list  ('addr, 'heap) Jstate  bool"
               ("_,_,_  ((1_,/_) [-_→]/ (1_,/_))" [51,51,0,0,0,0,0,0] 81)
for extTA :: "('addr, 'thread_id, 'heap) external_thread_action  ('addr, 'thread_id, 'x, 'heap) Jinja_thread_action"
and P :: "'addr J_prog" and t :: 'thread_id
where
  RedNew:
  "(h', a)  allocate h (Class_type C)
   extTA,P,t  new C, (h, l) -NewHeapElem a (Class_type C) addr a, (h', l)"

| RedNewFail:
  "allocate h (Class_type C) = {}
   extTA,P,t  new C, (h, l) -ε THROW OutOfMemory, (h, l)"

| NewArrayRed:
  "extTA,P,t  e, s -ta e', s'  extTA,P,t  newA Te, s -ta newA Te', s'"

| RedNewArray:
  " 0 <=s i; (h', a)  allocate h (Array_type T (nat (sint i))) 
   extTA,P,t  newA TVal (Intg i), (h, l) -NewHeapElem a (Array_type T (nat (sint i))) addr a, (h', l)"

| RedNewArrayNegative:
  "i <s 0  extTA,P,t  newA TVal (Intg i), s -ε THROW NegativeArraySize, s"

| RedNewArrayFail:
  " 0 <=s i; allocate h (Array_type T (nat (sint i))) = {} 
   extTA,P,t  newA TVal (Intg i), (h, l) -ε THROW OutOfMemory, (h, l)"

| CastRed:
  "extTA,P,t  e, s -ta e', s'  extTA,P,t  Cast C e, s -ta Cast C e', s'"

| RedCast:
 " typeofhp s v = U; P  U  T 
   extTA,P,t  Cast T (Val v), s -ε Val v, s"

| RedCastFail:
  " typeofhp s v = U; ¬ P  U  T 
   extTA,P,t  Cast T (Val v), s -ε THROW ClassCast, s"

| InstanceOfRed:
  "extTA,P,t  e, s -ta e', s'  extTA,P,t  e instanceof T, s -ta e' instanceof T, s'"

| RedInstanceOf:
  " typeofhp s v = U; b  v  Null  P  U  T 
    extTA,P,t  (Val v) instanceof T, s -ε Val (Bool b), s"

| BinOpRed1:
  "extTA,P,t  e, s -ta e', s'  extTA,P,t  e «bop» e2, s -ta e' «bop» e2, s'"

| BinOpRed2:
  "extTA,P,t  e, s -ta e', s'  extTA,P,t  (Val v) «bop» e, s -ta (Val v) «bop» e', s'"

| RedBinOp:
  "binop bop v1 v2 = Some (Inl v) 
  extTA,P,t  (Val v1) «bop» (Val v2), s -ε Val v, s"

| RedBinOpFail:
  "binop bop v1 v2 = Some (Inr a) 
  extTA,P,t  (Val v1) «bop» (Val v2), s -ε Throw a, s"

| RedVar:
  "lcl s V = Some v 
  extTA,P,t  Var V, s -ε Val v, s"

| LAssRed:
  "extTA,P,t  e, s -ta e', s'  extTA,P,t  V:=e, s -ta V:=e', s'"

| RedLAss:
  "extTA,P,t  V:=(Val v), (h, l) -ε unit, (h, l(V  v))"

| AAccRed1:
  "extTA,P,t  a, s -ta a', s'  extTA,P,t  ai, s -ta a'i, s'"

| AAccRed2:
  "extTA,P,t  i, s -ta i', s'  extTA,P,t  (Val a)i, s -ta (Val a)i', s'"

| RedAAccNull:
  "extTA,P,t  nullVal i, s -ε THROW NullPointer, s"

| RedAAccBounds:
  " typeof_addr (hp s) a = Array_type T n; i <s 0  sint i  int n 
   extTA,P,t  (addr a)Val (Intg i), s -ε THROW ArrayIndexOutOfBounds, s"

| RedAAcc:
  " typeof_addr h a = Array_type T n; 0 <=s i; sint i < int n;
     heap_read h a (ACell (nat (sint i))) v 
   extTA,P,t  (addr a)Val (Intg i), (h, l) -ReadMem a (ACell (nat (sint i))) v Val v, (h, l)"

| AAssRed1:
  "extTA,P,t  a, s -ta a', s'  extTA,P,t  ai := e, s -ta a'i := e, s'"

| AAssRed2:
  "extTA,P,t  i, s -ta i', s'  extTA,P,t  (Val a)i := e, s -ta (Val a)i' := e, s'"

| AAssRed3:
  "extTA,P,t  (e::'addr expr), s -ta e', s'  extTA,P,t  (Val a)Val i := e, s -ta (Val a)Val i := e', s'"

| RedAAssNull:
  "extTA,P,t  nullVal i := (Val e::'addr expr), s -ε THROW NullPointer, s"

| RedAAssBounds:
  " typeof_addr (hp s) a = Array_type T n; i <s 0  sint i  int n 
   extTA,P,t  (addr a)Val (Intg i) := (Val e::'addr expr), s -ε THROW ArrayIndexOutOfBounds, s"

| RedAAssStore:
  " typeof_addr (hp s) a = Array_type T n; 0 <=s i; sint i < int n;
     typeofhp s w = U; ¬ (P  U  T) 
   extTA,P,t  (addr a)Val (Intg i) := (Val w::'addr expr), s -ε THROW ArrayStore, s"

| RedAAss:
  " typeof_addr h a = Array_type T n; 0 <=s i; sint i < int n; typeofh w = Some U; P  U  T;
     heap_write h a (ACell (nat (sint i))) w h' 
   extTA,P,t  (addr a)Val (Intg i) := Val w::'addr expr, (h, l) -WriteMem a (ACell (nat (sint i))) w unit, (h', l)"

| ALengthRed:
  "extTA,P,t  a, s -ta a', s'  extTA,P,t  a∙length, s -ta a'∙length, s'"

| RedALength:
  "typeof_addr h a = Array_type T n 
   extTA,P,t  addr a∙length, (h, l) -ε Val (Intg (word_of_nat n)), (h, l)"

| RedALengthNull:
  "extTA,P,t  null∙length, s -ε THROW NullPointer, s"

| FAccRed:
  "extTA,P,t  e, s -ta e', s'  extTA,P,t  eF{D}, s -ta e'F{D}, s'"

| RedFAcc:
  "heap_read h a (CField D F) v
   extTA,P,t  (addr a)F{D}, (h, l) -ReadMem a (CField D F) v Val v, (h, l)"

| RedFAccNull:
  "extTA,P,t  nullF{D}, s -ε THROW NullPointer, s"

| FAssRed1:
  "extTA,P,t  e, s -ta e', s'  extTA,P,t  eF{D}:=e2, s -ta e'F{D}:=e2, s'"

| FAssRed2:
  "extTA,P,t  (e::'addr expr), s -ta e', s'  extTA,P,t  Val vF{D}:=e, s -ta Val vF{D}:=e', s'"

| RedFAss:
  "heap_write h a (CField D F) v h' 
  extTA,P,t  (addr a)F{D}:= Val v, (h, l) -WriteMem a (CField D F) v unit, (h', l)"

| RedFAssNull:
  "extTA,P,t  nullF{D}:=Val v::'addr expr, s -ε THROW NullPointer, s"

| CASRed1:
  "extTA,P,t  e, s -ta e', s' 
  extTA,P,t  e∙compareAndSwap(DF, e2, e3), s -ta e'∙compareAndSwap(DF, e2, e3), s'"

| CASRed2:
  "extTA,P,t  e, s -ta e', s' 
  extTA,P,t  Val v∙compareAndSwap(DF, e, e3), s -ta Val v∙compareAndSwap(DF, e', e3), s'"

| CASRed3:
  "extTA,P,t  e, s -ta e', s' 
  extTA,P,t  Val v∙compareAndSwap(DF, Val v', e), s -ta Val v∙compareAndSwap(DF, Val v', e'), s'"

| CASNull:
  "extTA,P,t  null∙compareAndSwap(DF, Val v, Val v'), s -ε THROW NullPointer, s"

| RedCASSucceed:
  " heap_read h a (CField D F) v; heap_write h a (CField D F) v' h'  
  extTA,P,t  addr a∙compareAndSwap(DF, Val v, Val v'), (h, l) 
  -ReadMem a (CField D F) v, WriteMem a (CField D F) v' 
  true, (h', l)"

| RedCASFail:
  " heap_read h a (CField D F) v''; v  v''  
  extTA,P,t  addr a∙compareAndSwap(DF, Val v, Val v'), (h, l) 
  -ReadMem a (CField D F) v'' 
  false, (h, l)"

| CallObj:
  "extTA,P,t  e, s -ta e', s'  extTA,P,t  eM(es), s -ta e'M(es), s'"

| CallParams:
  "extTA,P,t  es, s [-ta→] es',s' 
  extTA,P,t  (Val v)M(es),s -ta (Val v)M(es'),s'"

| RedCall:
  " typeof_addr (hp s) a = hU; P  class_type_of hU sees M:TsT = (pns,body) in D; 
    size vs = size pns; size Ts = size pns 
   extTA,P,t  (addr a)M(map Val vs), s -ε blocks (this # pns) (Class D # Ts) (Addr a # vs) body, s"

| RedCallExternal:
  " typeof_addr (hp s) a = hU; P  class_type_of hU sees M:TsT = Native in D;
     P,t  aM(vs), hp s -ta→ext va, h';
     ta' = extTA ta; e' = extRet2J ((addr a)M(map Val vs)) va; s' = (h', lcl s) 
   extTA,P,t  (addr a)M(map Val vs), s -ta' e', s'"

| RedCallNull:
  "extTA,P,t  nullM(map Val vs), s -ε THROW NullPointer, s"

| BlockRed:
  "extTA,P,t  e, (h, l(V:=vo)) -ta e', (h', l')
   extTA,P,t  {V:T=vo; e}, (h, l) -ta {V:T=l' V; e'}, (h', l'(V := l V))"

| RedBlock:
  "extTA,P,t  {V:T=vo; Val u}, s -ε Val u, s"

| SynchronizedRed1:
  "extTA,P,t  o', s -ta o'', s'  extTA,P,t  sync(o') e, s -ta sync(o'') e, s'"

| SynchronizedNull:
  "extTA,P,t  sync(null) e, s -ε THROW NullPointer, s"

| LockSynchronized:
  "extTA,P,t  sync(addr a) e, s -Locka, SyncLock a insync(a) e, s"

| SynchronizedRed2:
  "extTA,P,t  e, s -ta e', s'  extTA,P,t  insync(a) e, s -ta insync(a) e', s'"

| UnlockSynchronized:
  "extTA,P,t  insync(a) (Val v), s -Unlocka, SyncUnlock a Val v, s"

| SeqRed:
  "extTA,P,t  e, s -ta e', s'  extTA,P,t  e;;e2, s -ta e';;e2, s'"

| RedSeq:
  "extTA,P,t  (Val v);;e, s -ε e, s"

| CondRed:
  "extTA,P,t  b, s -ta b', s'  extTA,P,t  if (b) e1 else e2, s -ta if (b') e1 else e2, s'"

| RedCondT:
  "extTA,P,t  if (true) e1 else e2, s -ε e1, s"

| RedCondF:
  "extTA,P,t  if (false) e1 else e2, s -ε e2, s"

| RedWhile:
  "extTA,P,t  while(b) c, s -ε if (b) (c;;while(b) c) else unit, s"

| ThrowRed:
  "extTA,P,t  e, s -ta e', s'  extTA,P,t  throw e, s -ta throw e', s'"

| RedThrowNull:
  "extTA,P,t  throw null, s -ε THROW NullPointer, s"

| TryRed:
  "extTA,P,t  e, s -ta e', s'  extTA,P,t  try e catch(C V) e2, s -ta try e' catch(C V) e2, s'"

| RedTry:
  "extTA,P,t  try (Val v) catch(C V) e2, s -ε Val v, s"

| RedTryCatch:
  " typeof_addr (hp s) a = Class_type D; P  D * C 
   extTA,P,t  try (Throw a) catch(C V) e2, s -ε {V:Class C=Addr a; e2}, s"

| RedTryFail:
  " typeof_addr (hp s) a = Class_type D; ¬ P  D * C 
   extTA,P,t  try (Throw a) catch(C V) e2, s -ε Throw a, s"

| ListRed1:
  "extTA,P,t  e,s -ta e',s' 
  extTA,P,t  e#es,s [-ta→] e'#es,s'"

| ListRed2:
  "extTA,P,t  es,s [-ta→] es',s' 
  extTA,P,t  Val v # es,s [-ta→] Val v # es',s'"

― ‹Exception propagation›

| NewArrayThrow: "extTA,P,t  newA TThrow a, s -ε Throw a, s"
| CastThrow: "extTA,P,t  Cast C (Throw a), s -ε Throw a, s"
| InstanceOfThrow: "extTA,P,t  (Throw a) instanceof T, s -ε Throw a, s"
| BinOpThrow1: "extTA,P,t  (Throw a) «bop» e2, s -ε Throw a, s"
| BinOpThrow2: "extTA,P,t  (Val v1) «bop» (Throw a), s -ε Throw a, s"
| LAssThrow: "extTA,P,t  V:=(Throw a), s -ε Throw a, s"
| AAccThrow1: "extTA,P,t  (Throw a)i, s -ε Throw a, s"
| AAccThrow2: "extTA,P,t  (Val v)Throw a, s -ε Throw a, s"
| AAssThrow1: "extTA,P,t  (Throw a)i := e, s -ε Throw a, s"
| AAssThrow2: "extTA,P,t  (Val v)Throw a := e, s -ε Throw a, s"
| AAssThrow3: "extTA,P,t  (Val v)Val i := Throw a :: 'addr expr, s -ε Throw a, s"
| ALengthThrow: "extTA,P,t  (Throw a)∙length, s -ε Throw a, s"
| FAccThrow: "extTA,P,t  (Throw a)F{D}, s -ε Throw a, s"
| FAssThrow1: "extTA,P,t  (Throw a)F{D}:=e2, s -ε Throw a, s"
| FAssThrow2: "extTA,P,t  Val vF{D}:=(Throw a::'addr expr), s -ε Throw a, s"
| CASThrow: "extTA,P,t  Throw a∙compareAndSwap(DF, e2, e3), s -ε Throw a, s"
| CASThrow2: "extTA,P,t  Val v∙compareAndSwap(DF, Throw a, e3), s -ε Throw a, s"
| CASThrow3: "extTA,P,t  Val v∙compareAndSwap(DF, Val v', Throw a), s -ε Throw a, s"
| CallThrowObj: "extTA,P,t  (Throw a)M(es), s -ε Throw a, s"
| CallThrowParams: " es = map Val vs @ Throw a # es'   extTA,P,t  (Val v)M(es), s -ε Throw a, s"
| BlockThrow: "extTA,P,t  {V:T=vo; Throw a}, s -ε Throw a, s"
| SynchronizedThrow1: "extTA,P,t  sync(Throw a) e, s -ε Throw a, s"
| SynchronizedThrow2: "extTA,P,t  insync(a) Throw ad, s -Unlocka, SyncUnlock a Throw ad, s"
| SeqThrow: "extTA,P,t  (Throw a);;e2, s -ε Throw a, s"
| CondThrow: "extTA,P,t  if (Throw a) e1 else e2, s -ε Throw a, s"
| ThrowThrow: "extTA,P,t  throw(Throw a), s -ε Throw a, s"

inductive_cases red_cases:
  "extTA,P,t  new C, s -ta e', s'"
  "extTA,P,t  newA Te, s -ta e', s'"
  "extTA,P,t  Cast T e, s -ta e', s'"
  "extTA,P,t  e instanceof T, s -ta e', s'"
  "extTA,P,t  e «bop» e', s -ta e'', s'"
  "extTA,P,t  Var V, s -ta e', s'"
  "extTA,P,t  V:=e, s -ta e', s'"
  "extTA,P,t  ai, s -ta e', s'"
  "extTA,P,t  ai := e, s -ta e', s'"
  "extTA,P,t  a∙length, s -ta e', s'"
  "extTA,P,t  eF{D}, s -ta e', s'"
  "extTA,P,t  eF{D} := e', s -ta e'', s'"
  "extTA,P,t  e∙compareAndSwap(DF, e', e''), s -ta e''', s'"
  "extTA,P,t  eM(es), s -ta e', s'"
  "extTA,P,t  {V:T=vo; e}, s -ta e', s'"
  "extTA,P,t  sync(o') e, s -ta e', s'"
  "extTA,P,t  insync(a) e, s -ta e', s'"
  "extTA,P,t  e;;e', s -ta e'', s'"
  "extTA,P,t  if (b) e1 else e2, s  -ta e', s'"
  "extTA,P,t  while (b) e, s  -ta e', s'"
  "extTA,P,t  throw e, s  -ta e', s'"
  "extTA,P,t  try e catch(C V) e', s -ta e'', s'"

inductive_cases reds_cases:
  "extTA,P,t  e # es, s [-ta→] es', s'"

abbreviation red' ::
  "'addr J_prog  'thread_id  'addr expr  ('heap × 'addr locals) 
   ('addr, 'thread_id, 'heap) J_thread_action  'addr expr  ('heap × 'addr locals)  bool"
  ("_,_  ((1_,/_) -_/ (1_,/_))" [51,0,0,0,0,0,0] 81)
where "red' P  red (extTA2J P) P"

abbreviation reds' :: 
  "'addr J_prog  'thread_id  'addr expr list  ('heap × 'addr locals)
   ('addr, 'thread_id, 'heap) J_thread_action  'addr expr list  ('heap × 'addr locals)  bool"
  ("_,_  ((1_,/_) [-_→]/ (1_,/_))" [51,0,0,0,0,0,0] 81)
where "reds' P  reds (extTA2J P) P"

subsection‹Some easy lemmas›

lemma [iff]:
  "¬ extTA,P,t  Val v, s -ta e', s'"
by(fastforce elim:red.cases)

lemma red_no_val [dest]:
  " extTA,P,t  e, s -tas e', s'; is_val e   False"
by(auto)

lemma [iff]: "¬ extTA,P,t  Throw a, s -ta e', s'"
by(fastforce elim: red_cases)

lemma reds_map_Val_Throw:
  "extTA,P,t  map Val vs @ Throw a # es, s [-ta→] es', s'  False"
by(induct vs arbitrary: es')(auto elim!: reds_cases)

lemma reds_preserves_len:
  "extTA,P,t  es, s [-ta→] es', s'  length es' = length es"
by(induct es arbitrary: es')(auto elim: reds.cases)

lemma red_lcl_incr: "extTA,P,t  e, s -ta e', s'  dom (lcl s)  dom (lcl s')"
  and reds_lcl_incr: "extTA,P,t  es, s [-ta→] es', s'  dom (lcl s)  dom (lcl s')"
apply(induct rule:red_reds.inducts)
apply(auto simp del: fun_upd_apply split: if_split_asm)
done

lemma red_lcl_add_aux:
  "extTA,P,t  e, s -ta e', s'  extTA,P,t  e, (hp s, l0 ++ lcl s) -ta e', (hp s', l0 ++ lcl s')"
  and reds_lcl_add_aux:
  "extTA,P,t  es, s [-ta→] es', s'  extTA,P,t  es, (hp s, l0 ++ lcl s) [-ta→] es', (hp s', l0 ++ lcl s')"
proof (induct arbitrary: l0 and l0 rule:red_reds.inducts)
  case (BlockRed e h x V vo ta e' h' x' T)
  note IH = l0. extTA,P,t  e,(hp (h, x(V := vo)), l0 ++ lcl (h, x(V := vo))) -ta e',(hp (h', x'), l0 ++ lcl (h', x'))[simplified]
  have lrew: "x x'. x(V := vo) ++ x'(V := vo) = (x ++ x')(V := vo)" 
    by(simp add:fun_eq_iff map_add_def)
  have lrew1: "X X' X'' vo. (X(V := vo) ++ X')(V := (X ++ X'') V) = X ++ X'(V := X'' V)"
    by(simp add: fun_eq_iff map_add_def)
  have lrew2: "X X'. (X(V := None) ++ X') V = X' V"
    by(simp add: map_add_def) 
  show ?case
  proof(cases vo)
    case None
    from IH[of "l0(V := vo)"]
    show ?thesis
      apply(simp del: fun_upd_apply add: lrew)
      apply(drule red_reds.BlockRed)
      by(simp only: lrew1 None lrew2)
  next
    case (Some v)
    with extTA,P,t  e,(h, x(V := vo)) -ta e',(h', x')
    have "x' V  None"
      by -(drule red_lcl_incr, auto split: if_split_asm)
    with IH[of "l0(V := vo)"]
    show ?thesis
      apply(clarsimp simp del: fun_upd_apply simp add: lrew)
      apply(drule red_reds.BlockRed)
      by(simp add: lrew1 Some del: fun_upd_apply)
  qed
next
  case RedTryFail thus ?case
    by(auto intro: red_reds.RedTryFail)
qed(fastforce intro:red_reds.intros simp del: fun_upd_apply)+

lemma red_lcl_add: "extTA,P,t  e, (h, l) -ta e', (h', l')  extTA,P,t  e, (h, l0 ++ l) -ta e', (h', l0 ++ l')"
  and reds_lcl_add: "extTA,P,t  es, (h, l) [-ta→] es', (h', l')  extTA,P,t  es, (h, l0 ++ l) [-ta→] es', (h', l0 ++ l')"
by(auto dest:red_lcl_add_aux reds_lcl_add_aux)

lemma reds_no_val [dest]:
  " extTA,P,t  es, s [-ta→] es', s'; is_vals es   False"
apply(induct es arbitrary: s ta es' s')
 apply(blast elim: reds.cases)
apply(erule reds.cases)
apply(auto, blast)
done

lemma red_no_Throw [dest!]:
  "extTA,P,t  Throw a, s -ta e', s'  False"
by(auto elim!: red_cases)

lemma red_lcl_sub:
  " extTA,P,t  e, s -ta e', s'; fv e  W  
   extTA,P,t  e, (hp s, (lcl s)|`W) -ta e', (hp s', (lcl s')|`W)"

  and reds_lcl_sub:
  " extTA,P,t  es, s [-ta→] es', s'; fvs es  W 
   extTA,P,t  es, (hp s, (lcl s)|`W) [-ta→] es', (hp s', (lcl s')|`W)"
proof(induct arbitrary: W and W rule: red_reds.inducts)
  case (RedLAss V v h l W)
  have "extTA,P,t  V:=Val v,(h, l |` W) -ε unit,(h, (l |`W)(V  v))"
    by(rule red_reds.RedLAss)
  with RedLAss show ?case by(simp del: fun_upd_apply)
next
  case (BlockRed e h x V vo ta e' h' x' T)
  have IH: "W. fv e  W  extTA,P,t  e,(hp (h, x(V := vo)), lcl (h, x(V := vo)) |` W) -ta e',(hp (h', x'), lcl (h', x') |` W)" by fact
  from ‹fv {V:T=vo; e}  W have fve: "fv e  insert V W" by auto
  show ?case
  proof(cases "V  W")
    case True
    with fve have "fv e  W" by auto
    from True IH[OF this] have "extTA,P,t  e,(h, (x |` W )(V := vo)) -ta e',(h', x' |` W)" by(simp)
    with True have "extTA,P,t  {V:T=vo; e},(h, x |` W) -ta {V:T=x' V; e'},(h', (x' |` W)(V := x V))"
      by -(drule red_reds.BlockRed[where T=T], simp)
    with True show ?thesis by(simp del: fun_upd_apply)
  next
    case False
    with IH[OF fve] have "extTA,P,t  e,(h, (x |` W)(V := vo)) -ta e',(h', x' |` insert V W)" by(simp)
    with False have "extTA,P,t  {V:T=vo; e},(h, x |` W) -ta {V:T=x' V; e'},(h', (x' |` W))"
      by -(drule red_reds.BlockRed[where T=T],simp)
    with False show ?thesis by(simp del: fun_upd_apply)
  qed
next
  case RedTryFail thus ?case by(auto intro: red_reds.RedTryFail)
qed(fastforce intro: red_reds.intros)+

lemma red_notfree_unchanged: " extTA,P,t  e, s -ta e', s'; V  fv e   lcl s' V = lcl s V"
  and reds_notfree_unchanged: " extTA,P,t  es, s [-ta→] es', s'; V  fvs es   lcl s' V = lcl s V"
apply(induct rule: red_reds.inducts)
apply(fastforce)+
done

lemma red_dom_lcl: "extTA,P,t  e, s -ta e', s'  dom (lcl s')  dom (lcl s)  fv e"
  and reds_dom_lcl: "extTA,P,t  es, s [-ta→] es', s'  dom (lcl s')  dom (lcl s)  fvs es"
proof (induct rule:red_reds.inducts)
  case (BlockRed e h x V vo ta e' h' x' T)
  thus ?case by(clarsimp)(fastforce split:if_split_asm)
qed auto

lemma red_Suspend_is_call:
  " convert_extTA extNTA,P,t  e, s -ta e', s'; Suspend w  set taw 
   a vs hT Ts Tr D. call e' = (a, wait, vs)  typeof_addr (hp s) a = hT  P  class_type_of hT sees wait:TsTr = Native in D"
  and reds_Suspend_is_calls:
  " convert_extTA extNTA,P,t  es, s [-ta→] es', s'; Suspend w  set taw 
   a vs hT Ts Tr D. calls es' = (a, wait, vs)  typeof_addr (hp s) a = hT  P  class_type_of hT sees wait:TsTr = Native in D"
proof(induct rule: red_reds.inducts)
  case RedCallExternal
  thus ?case
    apply clarsimp
    apply(frule red_external_Suspend_StaySame, simp)
    apply(drule red_external_Suspend_waitD, fastforce+)
    done
qed auto

end

context J_heap begin

lemma red_hext_incr: "extTA,P,t  e, s -ta e', s'  hp s  hp s'"
  and reds_hext_incr: "extTA,P,t  es, s [-ta→] es', s'  hp s  hp s'"
by(induct rule:red_reds.inducts)(auto intro: hext_heap_ops red_external_hext)

lemma red_preserves_tconf: " extTA,P,t  e, s -ta e', s'; P,hp s  t √t   P,hp s'  t √t"
by(drule red_hext_incr)(rule tconf_hext_mono)

lemma reds_preserves_tconf: " extTA,P,t  es, s [-ta→] es', s'; P,hp s  t √t   P,hp s'  t √t"
by(drule reds_hext_incr)(rule tconf_hext_mono)

end

subsection ‹Code generation›

context J_heap_base begin

lemma RedCall_code:
  " is_vals es; typeof_addr (hp s) a = hU; P  class_type_of hU sees M:TsT = (pns,body) in D; 
    size es = size pns; size Ts = size pns 
   extTA,P,t  (addr a)M(es), s -ε blocks (this # pns) (Class D # Ts) (Addr a # map the_Val es) body, s"

  and RedCallExternal_code:
  " is_vals es; typeof_addr (hp s) a = hU; P  class_type_of hU sees M:TsT = Native in D;
     P,t  aM(map the_Val es), hp s -ta→ext va, h' 
   extTA,P,t  (addr a)M(es), s -extTA ta extRet2J ((addr a)M(es)) va, (h', lcl s)"

  and RedCallNull_code:
  "is_vals es  extTA,P,t  nullM(es), s -ε THROW NullPointer, s"
  
  and CallThrowParams_code:
  "is_Throws es  extTA,P,t  (Val v)M(es), s -ε hd (dropWhile is_val es), s"

apply(auto simp add: is_vals_conv is_Throws_conv o_def intro: RedCall RedCallExternal RedCallNull simp del: blocks.simps)
apply(subst dropWhile_append2)
apply(auto intro: CallThrowParams)
done

end

lemmas [code_pred_intro] = 
  J_heap_base.RedNew[folded Predicate_Compile.contains_def] J_heap_base.RedNewFail J_heap_base.NewArrayRed 
  J_heap_base.RedNewArray[folded Predicate_Compile.contains_def]
  J_heap_base.RedNewArrayNegative J_heap_base.RedNewArrayFail
  J_heap_base.CastRed J_heap_base.RedCast J_heap_base.RedCastFail J_heap_base.InstanceOfRed
  J_heap_base.RedInstanceOf J_heap_base.BinOpRed1 J_heap_base.BinOpRed2 J_heap_base.RedBinOp J_heap_base.RedBinOpFail 
  J_heap_base.RedVar J_heap_base.LAssRed J_heap_base.RedLAss
  J_heap_base.AAccRed1 J_heap_base.AAccRed2 J_heap_base.RedAAccNull
  J_heap_base.RedAAccBounds J_heap_base.RedAAcc J_heap_base.AAssRed1 J_heap_base.AAssRed2 J_heap_base.AAssRed3
  J_heap_base.RedAAssNull J_heap_base.RedAAssBounds J_heap_base.RedAAssStore J_heap_base.RedAAss J_heap_base.ALengthRed
  J_heap_base.RedALength J_heap_base.RedALengthNull J_heap_base.FAccRed J_heap_base.RedFAcc J_heap_base.RedFAccNull
  J_heap_base.FAssRed1 J_heap_base.FAssRed2 J_heap_base.RedFAss J_heap_base.RedFAssNull
  J_heap_base.CASRed1 J_heap_base.CASRed2 J_heap_base.CASRed3 J_heap_base.CASNull J_heap_base.RedCASSucceed J_heap_base.RedCASFail
  J_heap_base.CallObj J_heap_base.CallParams

declare
  J_heap_base.RedCall_code[code_pred_intro RedCall_code]
  J_heap_base.RedCallExternal_code[code_pred_intro RedCallExternal_code]
  J_heap_base.RedCallNull_code[code_pred_intro RedCallNull_code]

lemmas [code_pred_intro] =
  J_heap_base.BlockRed J_heap_base.RedBlock J_heap_base.SynchronizedRed1 J_heap_base.SynchronizedNull
  J_heap_base.LockSynchronized J_heap_base.SynchronizedRed2 J_heap_base.UnlockSynchronized
  J_heap_base.SeqRed J_heap_base.RedSeq J_heap_base.CondRed J_heap_base.RedCondT J_heap_base.RedCondF J_heap_base.RedWhile
  J_heap_base.ThrowRed

declare
  J_heap_base.RedThrowNull[code_pred_intro RedThrowNull']

lemmas [code_pred_intro] =
  J_heap_base.TryRed J_heap_base.RedTry J_heap_base.RedTryCatch
  J_heap_base.RedTryFail J_heap_base.ListRed1 J_heap_base.ListRed2
  J_heap_base.NewArrayThrow J_heap_base.CastThrow J_heap_base.InstanceOfThrow J_heap_base.BinOpThrow1 J_heap_base.BinOpThrow2
  J_heap_base.LAssThrow J_heap_base.AAccThrow1 J_heap_base.AAccThrow2 J_heap_base.AAssThrow1 J_heap_base.AAssThrow2
  J_heap_base.AAssThrow3 J_heap_base.ALengthThrow J_heap_base.FAccThrow J_heap_base.FAssThrow1 J_heap_base.FAssThrow2
  J_heap_base.CASThrow J_heap_base.CASThrow2 J_heap_base.CASThrow3
  J_heap_base.CallThrowObj 

declare
  J_heap_base.CallThrowParams_code[code_pred_intro CallThrowParams_code]

lemmas [code_pred_intro] =
  J_heap_base.BlockThrow J_heap_base.SynchronizedThrow1 J_heap_base.SynchronizedThrow2 J_heap_base.SeqThrow
  J_heap_base.CondThrow

declare
  J_heap_base.ThrowThrow[code_pred_intro ThrowThrow']

code_pred
  (modes:
    J_heap_base.red: i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ (i ⇒ i ⇒ i ⇒ o ⇒ bool)(i ⇒ i ⇒ i ⇒ i ⇒ o ⇒ bool) ⇒ i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ o ⇒ o ⇒ o ⇒ bool 
   and
    J_heap_base.reds: i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ (i ⇒ i ⇒ i ⇒ o ⇒ bool)(i ⇒ i ⇒ i ⇒ i ⇒ o ⇒ bool) ⇒ i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ o ⇒ o ⇒ o ⇒ bool)
  [detect_switches, skip_proof] ― ‹proofs are possible, but take veeerry long›
  J_heap_base.red
proof -
  case red
  from red.prems show thesis
  proof(cases rule: J_heap_base.red.cases[consumes 1, case_names
    RedNew RedNewFail NewArrayRed RedNewArray RedNewArrayNegative RedNewArrayFail CastRed RedCast RedCastFail InstanceOfRed
    RedInstanceOf BinOpRed1 BinOpRed2 RedBinOp RedBinOpFail RedVar LAssRed RedLAss
    AAccRed1 AAccRed2 RedAAccNull RedAAccBounds RedAAcc
    AAssRed1 AAssRed2 AAssRed3 RedAAssNull RedAAssBounds RedAAssStore RedAAss ALengthRed RedALength RedALengthNull FAccRed
    RedFAcc RedFAccNull FAssRed1 FAssRed2 RedFAss RedFAssNull CASRed1 CASRed2 CASRed3 RedCASNull RedCASSucceed RedCASFail 
    CallObj CallParams RedCall RedCallExternal RedCallNull
    BlockRed RedBlock SynchronizedRed1 SynchronizedNull LockSynchronized SynchronizedRed2 UnlockSynchronized SeqRed
    RedSeq CondRed RedCondT RedCondF RedWhile ThrowRed RedThrowNull TryRed RedTry RedTryCatch RedTryFail
    NewArrayThrow CastThrow InstanceOfThrow BinOpThrow1 BinOpThrow2 LAssThrow AAccThrow1 AAccThrow2 AAssThrow1 AAssThrow2
    AAssThrow3 ALengthThrow FAccThrow FAssThrow1 FAssThrow2 CASThrow CASThrow2 CASThrow3 
    CallThrowObj CallThrowParams BlockThrow SynchronizedThrow1 
    SynchronizedThrow2 SeqThrow CondThrow ThrowThrow])

    case (RedCall s a U M Ts T pns body D vs)
    with red.RedCall_code[OF refl refl refl refl refl refl refl refl refl refl refl, of a M "map Val vs" s pns D Ts body U T]
    show ?thesis by(simp add: o_def)
  next
    case (RedCallExternal s a U M Ts T D vs ta va h' ta' e' s')
    with red.RedCallExternal_code[OF refl refl refl refl refl refl refl refl refl refl refl, of a M "map Val vs" s ta va h' U Ts T D]
    show ?thesis by(simp add: o_def)
  next
    case (RedCallNull M vs s)
    with red.RedCallNull_code[OF refl refl refl refl refl refl refl refl refl refl refl, of M "map Val vs" s]
    show ?thesis by(simp add: o_def)
  next
    case (CallThrowParams es vs a es' v M s)
    with red.CallThrowParams_code[OF refl refl refl refl refl refl refl refl refl refl refl, of v M "map Val vs @ Throw a # es'" s]
    show ?thesis 
      apply(auto simp add: is_Throws_conv)
      apply(erule meta_impE)
      apply(subst dropWhile_append2)
      apply auto
      done
  next
    case RedThrowNull thus ?thesis
      by-(erule (4) red.RedThrowNull'[OF refl refl refl refl refl refl refl refl refl refl refl])
  next
    case ThrowThrow thus ?thesis
      by-(erule (4) red.ThrowThrow'[OF refl refl refl refl refl refl refl refl refl refl refl])
  qed(assumption|erule (4) red.that[unfolded Predicate_Compile.contains_def, OF refl refl refl refl refl refl refl refl refl refl refl])+
next
  case reds
  from reds.prems show thesis
    by(rule J_heap_base.reds.cases)(assumption|erule (4) reds.that[OF refl refl refl refl refl refl refl refl refl refl refl])+
qed

end

Theory WWellForm

(*  Title:      JinjaThreads/J/WWellForm.thy
    Author:     Tobias Nipkow, Andreas Lochbihler
*)

section ‹Weak well-formedness of Jinja programs›

theory WWellForm
imports
  "../Common/WellForm"
  Expr
begin

definition
  wwf_J_mdecl :: "'addr J_prog  cname  'addr J_mb mdecl  bool"
where
  "wwf_J_mdecl P C    λ(M,Ts,T,(pns,body)).
  length Ts = length pns  distinct pns  this  set pns  fv body  {this}  set pns"

lemma wwf_J_mdecl[simp]:
  "wwf_J_mdecl P C (M,Ts,T,pns,body) =
  (length Ts = length pns  distinct pns  this  set pns  fv body  {this}  set pns)"
(*<*)by(simp add:wwf_J_mdecl_def)(*>*)

abbreviation wwf_J_prog :: "'addr J_prog  bool"
where "wwf_J_prog == wf_prog wwf_J_mdecl"

end

Theory WellType

(*  Title:      JinjaThreads/J/WellType.thy
    Author:     Tobias Nipkow, Andreas Lochbihler
*)

section ‹Well-typedness of Jinja expressions›

theory WellType
imports
  Expr
  State
  "../Common/ExternalCallWF"
  "../Common/WellForm"
  "../Common/SemiType"
begin

declare Listn.lesub_list_impl_same_size[simp del]
declare listE_length [simp del]

type_synonym 
  env  = "vname  ty"

inductive
  WT :: "(ty  ty  ty  bool)  'addr J_prog  env  'addr expr  ty  bool" ("_,_,_  _ :: _"   [51,51,51,51]50)
  and WTs :: "(ty  ty  ty  bool)  'addr J_prog  env  'addr expr list  ty list  bool" 
    ("_,_,_  _ [::] _"   [51,51,51,51]50)
  for is_lub :: "ty  ty  ty  bool" (" lub'((_,/ _)') = _" [51,51,51] 50)
  and P :: "'addr J_prog"
where

  WTNew:
  "is_class P C  
  is_lub,P,E  new C :: Class C"

| WTNewArray:
  " is_lub,P,E  e :: Integer; is_type P (T⌊⌉)  
  is_lub,P,E  newA Te :: T⌊⌉"

| WTCast:
  " is_lub,P,E  e :: T; P  U  T  P  T  U; is_type P U 
   is_lub,P,E  Cast U e :: U"

| WTInstanceOf:
  " is_lub,P,E  e :: T; P  U  T  P  T  U; is_type P U; is_refT U 
   is_lub,P,E  e instanceof U :: Boolean"

| WTVal:
  "typeof v = Some T 
  is_lub,P,E  Val v :: T"

| WTVar:
  "E V = Some T 
  is_lub,P,E  Var V :: T"

| WTBinOp:
  " is_lub,P,E  e1 :: T1; is_lub,P,E  e2 :: T2; P  T1«bop»T2 :: T 
   is_lub,P,E  e1«bop»e2 :: T"

| WTLAss:
  " E V = Some T;  is_lub,P,E  e :: T';  P  T'  T;  V  this 
   is_lub,P,E  V:=e :: Void"

| WTAAcc:
  " is_lub,P,E  a :: T⌊⌉; is_lub,P,E  i :: Integer 
   is_lub,P,E  ai :: T"

| WTAAss:
  " is_lub,P,E  a :: T⌊⌉; is_lub,P,E  i :: Integer; is_lub,P,E  e :: T'; P  T'  T 
   is_lub,P,E  ai := e :: Void"

| WTALength:
  "is_lub,P,E  a :: T⌊⌉  is_lub,P,E  a∙length :: Integer"

| WTFAcc:
  " is_lub,P,E  e :: U; class_type_of' U = C; P  C sees F:T (fm) in D 
   is_lub,P,E  eF{D} :: T"

| WTFAss:
  " is_lub,P,E  e1 :: U; class_type_of' U = C; P  C sees F:T (fm) in D; is_lub,P,E  e2 :: T'; P  T'  T 
   is_lub,P,E  e1F{D}:=e2 :: Void"

| WTCAS:
  " is_lub,P,E  e1 :: U; class_type_of' U = C; P  C sees F:T (fm) in D; volatile fm; 
     is_lub,P,E  e2 :: T'; P  T'  T; is_lub,P,E  e3 :: T''; P  T''  T 
    is_lub,P,E  e1∙compareAndSwap(DF, e2, e3) :: Boolean"

| WTCall:
  " is_lub,P,E  e :: U; class_type_of' U = C; P  C sees M:Ts  T = meth in D;
     is_lub,P,E  es [::] Ts'; P  Ts' [≤] Ts 
   is_lub,P,E  eM(es) :: T"

| WTBlock:
  " is_type P T;  is_lub,P,E(V  T)  e :: T'; case vo of None  True | v  T'. typeof v = T'  P  T'  T 
    is_lub,P,E  {V:T=vo; e} :: T'"

| WTSynchronized:
  " is_lub,P,E  o' :: T; is_refT T; T  NT; is_lub,P,E  e :: T' 
   is_lub,P,E  sync(o') e :: T'"

― ‹Note that insync is not statically typable.›

| WTSeq:
  " is_lub,P,E  e1::T1;  is_lub,P,E  e2::T2 
    is_lub,P,E  e1;;e2 :: T2"

| WTCond:
  " is_lub,P,E  e :: Boolean;  is_lub,P,E  e1::T1;  is_lub,P,E  e2::T2;  lub(T1, T2) = T 
   is_lub,P,E  if (e) e1 else e2 :: T"

| WTWhile:
  " is_lub,P,E  e :: Boolean;  is_lub,P,E  c::T 
   is_lub,P,E  while (e) c :: Void"

| WTThrow:
  " is_lub,P,E  e :: Class C; P  C * Throwable   
  is_lub,P,E  throw e :: Void"

| WTTry:
  " is_lub,P,E  e1 :: T;  is_lub,P,E(V  Class C)  e2 :: T; P  C * Throwable 
   is_lub,P,E  try e1 catch(C V) e2 :: T"

| WTNil: "is_lub,P,E  [] [::] []"

| WTCons: " is_lub,P,E  e :: T; is_lub,P,E  es [::] Ts   is_lub,P,E  e#es [::] T#Ts"

abbreviation WT' :: "'addr J_prog  env  'addr expr  ty  bool" ("_,_  _ :: _" [51,51,51] 50)
where "WT' P  WT (TypeRel.is_lub P) P"

abbreviation WTs' :: "'addr J_prog  env  'addr expr list  ty list  bool" ("_,_  _ [::] _" [51,51,51] 50)
where "WTs' P  WTs (TypeRel.is_lub P) P"

declare WT_WTs.intros[intro!]

inductive_simps WTs_iffs [iff]:
  "is_lub',P,E  [] [::] Ts"
  "is_lub',P,E  e#es [::] T#Ts"
  "is_lub',P,E  e#es [::] Ts"

lemma WTs_conv_list_all2: 
  fixes is_lub 
  shows "is_lub,P,E  es [::] Ts = list_all2 (WT is_lub P E) es Ts"
by(induct es arbitrary: Ts)(auto simp add: list_all2_Cons1 elim: WTs.cases)

lemma WTs_append [iff]: "is_lub Ts. (is_lub,P,E  es1 @ es2 [::] Ts) =
  (Ts1 Ts2. Ts = Ts1 @ Ts2  is_lub,P,E  es1 [::] Ts1  is_lub,P,E  es2[::]Ts2)"
by(auto simp add: WTs_conv_list_all2 list_all2_append1 dest: list_all2_lengthD[symmetric])

inductive_simps WT_iffs [iff]:
  "is_lub',P,E  Val v :: T"
  "is_lub',P,E  Var V :: T"
  "is_lub',P,E  e1;;e2 :: T2"
  "is_lub',P,E  {V:T=vo; e} :: T'"

inductive_cases WT_elim_cases[elim!]:
  "is_lub',P,E  V :=e :: T"
  "is_lub',P,E  sync(o') e :: T"
  "is_lub',P,E  if (e) e1 else e2 :: T"
  "is_lub',P,E  while (e) c :: T"
  "is_lub',P,E  throw e :: T"
  "is_lub',P,E  try e1 catch(C V) e2 :: T"
  "is_lub',P,E  Cast D e :: T"
  "is_lub',P,E  e instanceof U :: T"
  "is_lub',P,E  aF{D} :: T"
  "is_lub',P,E  aF{D} := v :: T"
  "is_lub',P,E  e∙compareAndSwap(DF, e', e'') :: T"
  "is_lub',P,E  e1 «bop» e2 :: T"
  "is_lub',P,E  new C :: T"
  "is_lub',P,E  newA Te :: T'"
  "is_lub',P,E  ai := e :: T"
  "is_lub',P,E  ai :: T"
  "is_lub',P,E  a∙length :: T"
  "is_lub',P,E  eM(ps) :: T"
  "is_lub',P,E  sync(o') e :: T"
  "is_lub',P,E  insync(a) e :: T"

lemma fixes is_lub :: "ty  ty  ty  bool" (" lub'((_,/ _)') = _" [51,51,51] 50)
  assumes is_lub_unique: "T1 T2 T3 T4.   lub(T1, T2) = T3;  lub(T1, T2) = T4   T3 = T4"
  shows WT_unique: " is_lub,P,E  e :: T; is_lub,P,E  e :: T'   T = T'"
  and WTs_unique: " is_lub,P,E  es [::] Ts; is_lub,P,E  es [::] Ts'   Ts = Ts'"
apply(induct arbitrary: T' and Ts' rule: WT_WTs.inducts)
apply blast
apply blast
apply blast
apply blast
apply fastforce
apply fastforce
apply(fastforce dest: WT_binop_fun)
apply fastforce
apply fastforce
apply fastforce
apply fastforce
apply(fastforce dest: sees_field_fun)
apply(fastforce dest: sees_field_fun)
apply blast
apply(fastforce dest: sees_method_fun)
apply fastforce
apply fastforce
apply fastforce
apply(blast dest: is_lub_unique)
apply fastforce
apply fastforce
apply blast
apply fastforce
apply fastforce
done

lemma fixes is_lub
  shows wt_env_mono: "is_lub,P,E  e :: T  (E'. E m E'  is_lub,P,E'  e :: T)"
  and wts_env_mono: "is_lub,P,E  es [::] Ts  (E'. E m E'  is_lub,P,E'  es [::] Ts)"
apply(induct rule: WT_WTs.inducts)
apply(simp add: WTNew)
apply(simp add: WTNewArray)
apply(fastforce simp: WTCast)
apply(fastforce simp: WTInstanceOf)
apply(fastforce simp: WTVal)
apply(simp add: WTVar map_le_def dom_def)
apply(fastforce simp: WTBinOp)
apply(force simp:map_le_def)
apply(simp add: WTAAcc)
apply(simp add: WTAAss, fastforce)
apply(simp add: WTALength, fastforce)
apply(fastforce simp: WTFAcc)
apply(fastforce simp: WTFAss del:WT_WTs.intros WT_elim_cases)
apply blast
apply(fastforce)
apply(fastforce simp: map_le_def WTBlock)
apply(fastforce simp: WTSynchronized)
apply(fastforce simp: WTSeq)
apply(fastforce simp: WTCond)
apply(fastforce simp: WTWhile)
apply(fastforce simp: WTThrow)
apply(fastforce simp: WTTry map_le_def dom_def)
apply(fastforce)+
done

lemma fixes is_lub
  shows WT_fv: "is_lub,P,E  e :: T  fv e  dom E"
  and WT_fvs: "is_lub,P,E  es [::] Ts  fvs es  dom E"
apply(induct rule:WT_WTs.inducts)
apply(simp_all del: fun_upd_apply)
apply fast+
done

lemma fixes is_lub
  shows WT_expr_locks: "is_lub,P,E  e :: T  expr_locks e = (λad. 0)"
  and WTs_expr_lockss: "is_lub,P,E  es [::] Ts  expr_lockss es = (λad. 0)"
by(induct rule: WT_WTs.inducts)(auto)

lemma
  fixes is_lub :: "ty  ty  ty  bool" (" lub'((_,/ _)') = _" [51,51,51] 50)
  assumes is_lub_is_type: "T1 T2 T3.   lub(T1, T2) = T3; is_type P T1; is_type P T2   is_type P T3"
  and wf: "wf_prog wf_md P"
  shows WT_is_type: " is_lub,P,E  e :: T; ran E  types P   is_type P T"
  and WTs_is_type: " is_lub,P,E  es [::] Ts; ran E  types P   set Ts  types P"
apply(induct rule: WT_WTs.inducts)
apply simp
apply simp
apply simp
apply simp
apply (simp add:typeof_lit_is_type)
apply (fastforce intro:nth_mem simp add: ran_def)
apply(simp add: WT_binop_is_type)
apply(simp)
apply(simp del: is_type_array add: is_type_ArrayD)
apply(simp)
apply(simp)
apply(simp add:sees_field_is_type[OF _ wf])
apply(simp)
apply simp
apply(fastforce dest: sees_wf_mdecl[OF wf] simp:wf_mdecl_def)
apply(fastforce simp add: ran_def split: if_split_asm)
apply(simp add: is_class_Object[OF wf])
apply(simp)
apply(simp)
apply(fastforce intro: is_lub_is_type)
apply(simp)
apply(simp)
apply simp
apply simp
apply simp
done

lemma
  fixes is_lub1 :: "ty  ty  ty  bool" ("⊢1 lub'((_,/ _)') = _" [51,51,51] 50)
  and is_lub2 :: "ty  ty  ty  bool" ("⊢2 lub'((_,/ _)') = _" [51,51,51] 50)
  assumes wf: "wf_prog wf_md P"
  and is_lub1_into_is_lub2: "T1 T2 T3.  ⊢1 lub(T1, T2) = T3; is_type P T1; is_type P T2   ⊢2 lub(T1, T2) = T3"
  and is_lub2_is_type: "T1 T2 T3.  ⊢2 lub(T1, T2) = T3; is_type P T1; is_type P T2   is_type P T3"
  shows WT_change_is_lub: " is_lub1,P,E  e :: T; ran E  types P   is_lub2,P,E  e :: T"
  and WTs_change_is_lub: " is_lub1,P,E  es [::] Ts; ran E  types P   is_lub2,P,E  es [::] Ts"
proof(induct rule: WT_WTs.inducts)
  case (WTBlock U E V e' T vo)
  from ‹is_type P U ‹ran E  types P
  have "ran (E(V  U))  types P" by(auto simp add: ran_def)
  hence "is_lub2,P,E(V  U)  e' :: T" by(rule WTBlock)
  with ‹is_type P U show ?case
    using case vo of None  True | v  T'. typeof v = T'  P  T'  U by auto
next
  case (WTCond E e e1 T1 e2 T2 T)
  from ‹ran E  types P have "is_lub2,P,E  e :: Boolean" "is_lub2,P,E  e1 :: T1" "is_lub2,P,E  e2 :: T2"
    by(rule WTCond)+
  moreover from is_lub2_is_type wf is_lub2,P,E  e1 :: T1 ‹ran E  types P
  have "is_type P T1" by(rule WT_is_type)
  from is_lub2_is_type wf is_lub2,P,E  e2 :: T2 ‹ran E  types P
  have "is_type P T2" by(rule WT_is_type)
  with ⊢1 lub(T1, T2) = T ‹is_type P T1
  have "⊢2 lub(T1, T2) = T" by(rule is_lub1_into_is_lub2)
  ultimately show ?case ..
next
  case (WTTry E e1 T V C e2)
  from ‹ran E  types P have "is_lub2,P,E  e1 :: T" by(rule WTTry)
  moreover from P  C * Throwable› have "is_class P C"
    by(rule is_class_sub_Throwable[OF wf])
  with ‹ran E  types P have "ran (E(V  Class C))  types P"
    by(auto simp add: ran_def)
  hence "is_lub2,P,E(V  Class C)  e2 :: T" by(rule WTTry)
  ultimately show ?case using P  C * Throwable› ..
qed auto

subsection ‹Code generator setup›

lemma WTBlock_code:
  "is_lub.  is_type P T; is_lub,P,E(V  T)  e :: T'; 
     case vo of None  True | v  case typeof v of None  False | Some T'  P  T'  T 
    is_lub,P,E  {V:T=vo; e} :: T'"
by(auto)

lemmas [code_pred_intro] =
  WTNew WTNewArray WTCast WTInstanceOf WTVal WTVar WTBinOp WTLAss WTAAcc WTAAss WTALength WTFAcc WTFAss WTCAS WTCall 
declare 
  WTBlock_code [code_pred_intro WTBlock']
lemmas [code_pred_intro] =
  WTSynchronized WTSeq WTCond WTWhile WTThrow WTTry
  WTNil WTCons

code_pred
  (modes:
    (i ⇒ i ⇒ o ⇒ bool) ⇒ i ⇒ i ⇒ i ⇒ o ⇒ bool, 
    (i ⇒ i ⇒ o ⇒ bool) ⇒ i ⇒ i ⇒ i ⇒ i ⇒ bool)
  [detect_switches, skip_proof]
  WT
proof -
  case WT
  from WT.prems show thesis
  proof cases
    case (WTBlock T V e vo)
    thus thesis using WT.WTBlock'[OF refl refl refl, of V T vo e] by(auto)
  qed(assumption|erule WT.that[OF refl refl refl]|rule refl)+
next
  case WTs
  from WTs.prems WTs.that show thesis by cases blast+
qed

inductive is_lub_sup :: "'m prog  ty  ty  ty  bool"
for P T1 T2 T3
where
  "sup P T1 T2 = OK T3  is_lub_sup P T1 T2 T3"

code_pred
  (modes: i ⇒ i ⇒ i ⇒ o ⇒ bool, i ⇒ i ⇒ i ⇒ i ⇒ bool)
  is_lub_sup
.

definition WT_code :: "'addr J_prog  env  'addr expr  ty  bool" ("_,_  _ ::'' _" [51,51,51] 50)
where "WT_code P  WT (is_lub_sup P) P"

definition WTs_code :: "'addr J_prog  env  'addr expr list  ty list  bool" ("_,_  _ [::''] _" [51,51,51] 50)
where "WTs_code P  WTs (is_lub_sup P) P"

lemma assumes wf: "wf_prog wf_md P"
  shows WT_code_into_WT: 
  " P,E  e ::' T; ran E  types P   P,E  e :: T"

  and WTs_code_into_WTs:
  " P,E  es [::'] Ts; ran E  types P   P,E  es [::] Ts"
proof -
  assume ran: "ran E  types P"
  { assume wt: "P,E  e ::' T"
    show "P,E  e :: T"
      by(rule WT_change_is_lub[OF wf _ _ wt[unfolded WT_code_def] ran])(blast elim!: is_lub_sup.cases intro: sup_is_lubI[OF wf] is_lub_is_type[OF wf])+ }
  { assume wts: "P,E  es [::'] Ts"
    show "P,E  es [::] Ts"
      by(rule WTs_change_is_lub[OF wf _ _ wts[unfolded WTs_code_def] ran])(blast elim!: is_lub_sup.cases intro: sup_is_lubI[OF wf] is_lub_is_type[OF wf])+ }
qed

lemma assumes wf: "wf_prog wf_md P"
  shows WT_into_WT_code: 
  " P,E  e :: T; ran E  types P   P,E  e ::' T"

  and WT_into_WTs_code_OK:
  " P,E  es [::] Ts; ran E  types P   P,E  es [::'] Ts"
proof -
  assume ran: "ran E  types P"
  { assume wt: "P,E  e :: T"
    show "P,E  e ::' T" unfolding WT_code_def
      by(rule WT_change_is_lub[OF wf _ _ wt ran])(blast intro!: is_lub_sup.intros intro: is_lub_subD[OF wf] sup_is_type[OF wf] elim!: is_lub_sup.cases)+ }
  { assume wts: "P,E  es [::] Ts"
    show "P,E  es [::'] Ts" unfolding WTs_code_def
      by(rule WTs_change_is_lub[OF wf _ _ wts ran])(blast intro!: is_lub_sup.intros intro: is_lub_subD[OF wf] sup_is_type[OF wf] elim!: is_lub_sup.cases)+ }
qed

theorem WT_eq_WT_code:
  assumes "wf_prog wf_md P"
  and "ran E  types P"
  shows "P,E  e :: T  P,E  e ::' T"
using assms by(blast intro: WT_code_into_WT WT_into_WT_code)

code_pred
  (modes: i ⇒ i ⇒ i ⇒ i ⇒ bool, i ⇒ i ⇒ i ⇒ o ⇒ bool)
  [inductify]
  WT_code 
.

code_pred
  (modes: i ⇒ i ⇒ i ⇒ i ⇒ bool, i ⇒ i ⇒ i ⇒ o ⇒ bool)
  [inductify]
  WTs_code 
.

end

Theory DefAss

(*  Title:      JinjaThreads/J/DefAss.thy
    Author:     Tobias Nipkow, Andreas Lochbihler
*)

section ‹Definite assignment›

theory DefAss
imports 
  Expr
begin

subsection "Hypersets"

type_synonym 'a hyperset = "'a set option"

definition hyperUn :: "'a hyperset  'a hyperset  'a hyperset"   (infixl "" 65)
where
  "A  B    case A of None  None
                 | A  (case B of None  None | B  A  B)"

definition hyperInt :: "'a hyperset  'a hyperset  'a hyperset"   (infixl "" 70)
where
  "A  B    case A of None  B
                 | A  (case B of None  A | B  A  B)"

definition hyperDiff1 :: "'a hyperset  'a  'a hyperset"   (infixl "" 65)
where
  "A  a    case A of None  None | A  A - {a}"

definition hyper_isin :: "'a  'a hyperset  bool"   (infix "∈∈" 50)
where
 "a ∈∈ A    case A of None  True | A  a  A"

definition hyper_subset :: "'a hyperset  'a hyperset  bool"   (infix "" 50)
where
  "A  B    case B of None  True
                 | B  (case A of None  False | A  A  B)"

lemmas hyperset_defs =
 hyperUn_def hyperInt_def hyperDiff1_def hyper_isin_def hyper_subset_def

lemma [simp]: "{}  A = A    A  {} = A"
(*<*)by(simp add:hyperset_defs)(*>*)

lemma [simp]: "A  B = A  B  A  a = A - {a}"
(*<*)by(simp add:hyperset_defs)(*>*)

lemma [simp]: "None  A = None  A  None = None"
(*<*)by(simp add:hyperset_defs)(*>*)

lemma [simp]: "a ∈∈ None  None  a = None"
(*<*)by(simp add:hyperset_defs)(*>*)

lemma hyperUn_assoc: "(A  B)  C = A  (B  C)"
(*<*)by(simp add:hyperset_defs Un_assoc)(*>*)

lemma hyper_insert_comm: "A  {a} = {a}  A  A  ({a}  B) = {a}  (A  B)"
(*<*)by(simp add:hyperset_defs)(*>*)

lemma sqSub_mem_lem [elim]: " A  A'; a ∈∈ A   a ∈∈ A'"
by(auto simp add: hyperset_defs)

lemma [iff]: "A  None"
by(auto simp add: hyperset_defs)

lemma [simp]: "A  A"
by(auto simp add: hyperset_defs)

lemma [iff]: "A  B  A  B"
by(auto simp add: hyperset_defs)

lemma sqUn_lem2: "A  A'  B  A  B  A'"
by(simp add:hyperset_defs) blast

lemma sqSub_trans [trans, intro]: " A  B; B  C   A  C"
by(auto simp add: hyperset_defs)

lemma hyperUn_comm: "A  B = B  A"
by(auto simp add: hyperset_defs)

lemma hyperUn_leftComm: "A  (B  C) = B  (A  C)"
by(auto simp add: hyperset_defs)

lemmas hyperUn_ac = hyperUn_comm hyperUn_leftComm hyperUn_assoc

lemma [simp]: "{}  B = B"
by(auto)

lemma [simp]: "{}  A"
by(auto simp add: hyperset_defs)

lemma sqInt_lem: "A  A'  A  B  A'  B"
by(auto simp add: hyperset_defs)

subsection "Definite assignment"

primrec 𝒜  :: "('a,'b,'addr) exp  'a hyperset"
  and 𝒜s :: "('a,'b,'addr) exp list  'a hyperset"
where
  "𝒜 (new C) = {}"
| "𝒜 (newA Te) = 𝒜 e"
| "𝒜 (Cast C e) = 𝒜 e"
| "𝒜 (e instanceof T) = 𝒜 e"
| "𝒜 (Val v) = {}"
| "𝒜 (e1 «bop» e2) = 𝒜 e1  𝒜 e2"
| "𝒜 (Var V) = {}"
| "𝒜 (LAss V e) = {V}  𝒜 e"
| "𝒜 (ai) = 𝒜 a  𝒜 i"
| "𝒜 (ai := e) = 𝒜 a  𝒜 i  𝒜 e"
| "𝒜 (a∙length) = 𝒜 a"
| "𝒜 (eF{D}) = 𝒜 e"
| "𝒜 (e1F{D}:=e2) = 𝒜 e1  𝒜 e2"
| "𝒜 (e1∙compareAndSwap(DF, e2, e3)) = 𝒜 e1  𝒜 e2  𝒜 e3"
| "𝒜 (eM(es)) = 𝒜 e  𝒜s es"
| "𝒜 ({V:T=vo; e}) = 𝒜 e  V"
| "𝒜 (syncV (o') e) = 𝒜 o'  𝒜 e"
| "𝒜 (insyncV (a) e) = 𝒜 e"
| "𝒜 (e1;;e2) = 𝒜 e1  𝒜 e2"
| "𝒜 (if (e) e1 else e2) =  𝒜 e  (𝒜 e1  𝒜 e2)"
| "𝒜 (while (b) e) = 𝒜 b"
| "𝒜 (throw e) = None"
| "𝒜 (try e1 catch(C V) e2) = 𝒜 e1  (𝒜 e2  V)"

| "𝒜s ([]) = {}"
| "𝒜s (e#es) = 𝒜 e  𝒜s es"

primrec 𝒟  :: "('a,'b,'addr) exp  'a hyperset  bool"
  and 𝒟s :: "('a,'b,'addr) exp list  'a hyperset  bool"
where
  "𝒟 (new C) A = True"
| "𝒟 (newA Te) A = 𝒟 e A"
| "𝒟 (Cast C e) A = 𝒟 e A"
| "𝒟 (e instanceof T) = 𝒟 e"
| "𝒟 (Val v) A = True"
| "𝒟 (e1 «bop» e2) A = (𝒟 e1 A  𝒟 e2 (A  𝒜 e1))"
| "𝒟 (Var V) A = (V ∈∈ A)"
| "𝒟 (LAss V e) A = 𝒟 e A"
| "𝒟 (ai) A = (𝒟 a A  𝒟 i (A  𝒜 a))"
| "𝒟 (ai := e) A = (𝒟 a A  𝒟 i (A  𝒜 a)  𝒟 e (A  𝒜 a  𝒜 i))"
| "𝒟 (a∙length) A = 𝒟 a A"
| "𝒟 (eF{D}) A = 𝒟 e A"
| "𝒟 (e1F{D}:=e2) A = (𝒟 e1 A  𝒟 e2 (A  𝒜 e1))"
| "𝒟 (e1∙compareAndSwap(DF, e2, e3)) A = (𝒟 e1 A  𝒟 e2 (A  𝒜 e1)  𝒟 e3 (A  𝒜 e1  𝒜 e2))"
| "𝒟 (eM(es)) A = (𝒟 e A  𝒟s es (A  𝒜 e))"
| "𝒟 ({V:T=vo; e}) A = (if vo = None then 𝒟 e (A  V) else 𝒟 e (A  {V}))"
| "𝒟 (syncV (o') e) A = (𝒟 o' A  𝒟 e (A  𝒜 o'))"
| "𝒟 (insyncV (a) e) A = 𝒟 e A"
| "𝒟 (e1;;e2) A = (𝒟 e1 A  𝒟 e2 (A  𝒜 e1))"
| "𝒟 (if (e) e1 else e2) A = (𝒟 e A  𝒟 e1 (A  𝒜 e)  𝒟 e2 (A  𝒜 e))"
| "𝒟 (while (e) c) A = (𝒟 e A  𝒟 c (A  𝒜 e))"
| "𝒟 (throw e) A = 𝒟 e A"
| "𝒟 (try e1 catch(C V) e2) A = (𝒟 e1 A  𝒟 e2 (A  {V}))"

| "𝒟s ([]) A = True"
| "𝒟s (e#es) A = (𝒟 e A  𝒟s es (A  𝒜 e))"

lemma As_map_Val[simp]: "𝒜s (map Val vs) = {}"
(*<*)by (induct vs) simp_all(*>*)

lemma As_append [simp]: "𝒜s (xs @ ys) = (𝒜s xs)  (𝒜s ys)"
by(induct xs, auto simp add: hyperset_defs)

lemma Ds_map_Val[simp]: "𝒟s (map Val vs) A"
(*<*)by (induct vs) simp_all(*>*)

lemma D_append[iff]: "A. 𝒟s (es @ es') A = (𝒟s es A  𝒟s es' (A  𝒜s es))"
(*<*)by (induct es type:list) (auto simp:hyperUn_assoc)(*>*)


lemma fixes e :: "('a,'b,'addr) exp" and es :: "('a,'b,'addr) exp list"
  shows A_fv: "A. 𝒜 e = A  A  fv e"
  and  "A. 𝒜s es = A  A  fvs es"
apply(induct e and es rule: 𝒜.induct 𝒜s.induct)
apply (simp_all add:hyperset_defs)
apply fast+
done


lemma sqUn_lem: "A  A'  A  B  A'  B"
(*<*)by(simp add:hyperset_defs) blast(*>*)

lemma diff_lem: "A  A'  A  b  A'  b"
(*<*)by(simp add:hyperset_defs) blast(*>*)

(* This order of the premises avoids looping of the simplifier *)
lemma fixes e :: "('a, 'b, 'addr) exp" and es :: "('a, 'b, 'addr) exp list"
  shows D_mono: "A A'. A  A'  𝒟 e A  𝒟 e A'"
  and Ds_mono: "A A'. A  A'  𝒟s es A  𝒟s es A'"
(*<*)
apply(induct e and es rule: 𝒟.induct 𝒟s.induct)
subgoal by simp
subgoal by simp
subgoal by simp
subgoal by simp
subgoal by simp
subgoal by simp (iprover dest:sqUn_lem)
subgoal by(fastforce simp add:hyperset_defs)
subgoal by simp
subgoal by simp (iprover dest:sqUn_lem)
subgoal by simp (iprover dest:sqUn_lem)
subgoal by simp
subgoal by simp
subgoal by simp (iprover dest:sqUn_lem)
subgoal by simp (iprover dest:sqUn_lem)
subgoal by simp (iprover dest: sqUn_lem)
subgoal 
  apply(clarsimp split: if_split_asm) 
  apply (iprover dest:diff_lem) 
  apply(iprover dest: sqUn_lem)
  done
subgoal by simp (iprover dest:sqUn_lem)
subgoal by simp
subgoal by simp (iprover dest:sqUn_lem)
subgoal by simp (iprover dest:sqUn_lem)
subgoal by simp (iprover dest:sqUn_lem)
subgoal by simp
subgoal by simp (iprover dest:sqUn_lem)
subgoal by simp
subgoal by simp (iprover dest:sqUn_lem)
done
(*>*)

(* And this is the order of premises preferred during application: *)
lemma D_mono': "𝒟 e A  A  A'  𝒟 e A'"
and Ds_mono': "𝒟s es A  A  A'  𝒟s es A'"
(*<*)by(blast intro:D_mono, blast intro:Ds_mono)(*>*)

declare hyperUn_comm [simp]
declare hyperUn_leftComm [simp]

end

Theory JWellForm

(*  Title:      JinjaThreads/J/JWellForm.thy
    Author:     Tobias Nipkow, Andreas Lochbihler
*)

section ‹Well-formedness Constraints›

theory JWellForm
imports
  WWellForm
  WellType
  DefAss
begin

definition wf_J_mdecl :: "'addr J_prog  cname  'addr J_mb mdecl  bool"
where
  "wf_J_mdecl P C    λ(M,Ts,T,(pns,body)).
  length Ts = length pns 
  distinct pns 
  this  set pns 
  (T'. P,[thisClass C,pns[↦]Ts]  body :: T'  P  T'  T) 
  𝒟 body {this}  set pns"

lemma wf_J_mdecl[simp]:
  "wf_J_mdecl P C (M,Ts,T,pns,body) 
  (length Ts = length pns 
  distinct pns 
  this  set pns 
  (T'. P,[thisClass C,pns[↦]Ts]  body :: T'  P  T'  T) 
  𝒟 body {this}  set pns)"
(*<*)by(simp add:wf_J_mdecl_def)(*>*)


abbreviation wf_J_prog :: "'addr J_prog  bool"
where "wf_J_prog == wf_prog wf_J_mdecl"

lemma wf_mdecl_wwf_mdecl: "wf_J_mdecl P C Md  wwf_J_mdecl P C Md"
(*<*)
apply(clarsimp simp add: wwf_J_mdecl_def)
apply(frule WT_fv)
apply(auto)
done

lemma wf_prog_wwf_prog: "wf_J_prog P  wwf_J_prog P"
by(erule wf_prog_lift)(erule wf_mdecl_wwf_mdecl)

subsection ‹Code generation›

definition typeable_with :: "'addr J_prog  env  'addr expr  ty  bool"
where [simp]: "typeable_with P E e T  (T'. P,E  e ::' T'  P  T'  T)"

definition wf_J_mdecl' :: "'addr J_prog  cname  'addr J_mb mdecl  bool"
where
  "wf_J_mdecl' P C    λ(M,Ts,T,(pns,body)).
  length Ts = length pns 
  distinct pns 
  this  set pns 
  typeable_with P [thisClass C,pns[↦]Ts] body T 
  𝒟 body {this}  set pns"

definition wf_J_prog' :: "'addr J_prog  bool"
where "wf_J_prog' = wf_prog wf_J_mdecl'"

lemma wf_J_prog_wf_J_prog':
  "wf_J_prog P  wf_J_prog' P"
unfolding wf_J_prog'_def
apply(erule wf_prog_lift)
apply(clarsimp simp add: wf_J_mdecl'_def)
apply(drule (1) WT_into_WT_code)
apply(auto simp add: ran_def map_upds_def dest!: map_of_SomeD set_zip_rightD)
done

lemma wf_J_prog'_wf_J_prog:
  "wf_J_prog' P  wf_J_prog P"
unfolding wf_J_prog'_def
apply(erule wf_prog_lift)
apply(clarsimp simp add: wf_J_mdecl'_def)
apply(drule (1) WT_code_into_WT)
apply(auto simp add: ran_def map_upds_def dest!: map_of_SomeD set_zip_rightD)
done

lemma wf_J_prog_eq_wf_J_prog' [code_unfold]:
  "wf_J_prog = wf_J_prog'"
by(blast intro: ext wf_J_prog'_wf_J_prog wf_J_prog_wf_J_prog' del: equalityI)

code_pred 
  (modes: i ⇒ i ⇒ i ⇒ i ⇒ bool)
  [inductify]
  typeable_with 
.

text ‹Formal code generation test›
ML_val @{code wf_J_prog'}

end

Theory Threaded

(*  Title:      JinjaThreads/J/Threaded.thy
    Author:     Andreas Lochbihler
*)

section ‹The source language as an instance of the framework›

theory Threaded
imports
  SmallStep
  JWellForm
  "../Common/ConformThreaded"
  "../Common/ExternalCallWF"
  "../Framework/FWLiftingSem"
  "../Framework/FWProgressAux"
begin

context heap_base begin ― ‹Move to ?? - also used in BV›

lemma wset_Suspend_ok_start_state:
  fixes final r convert_RA
  assumes "start_state f P C M vs  I"
  shows "start_state f P C M vs  multithreaded_base.wset_Suspend_ok final r convert_RA I"
using assms
by(rule multithreaded_base.wset_Suspend_okI)(simp add: start_state_def split_beta)

end

abbreviation final_expr :: "'addr expr × 'addr locals  bool"where
  "final_expr  λ(e, x). final e"

lemma final_locks: "final e  expr_locks e l = 0"
by(auto elim: finalE)

context J_heap_base begin

abbreviation mred
  :: "'addr J_prog  ('addr, 'thread_id, 'addr expr × 'addr locals, 'heap, 'addr, ('addr, 'thread_id) obs_event) semantics"
where
  "mred P t  (λ((e, l), h)  ta ((e', l'), h'). P,t  e, (h, l) -ta e', (h', l'))"

lemma red_new_thread_heap:
  " convert_extTA extNTA,P,t  e, s -ta e', s'; NewThread t'' ex'' h''  set tat   h'' = hp s'"
  and reds_new_thread_heap:
  " convert_extTA extNTA,P,t  es, s [-ta→] es', s'; NewThread t'' ex'' h''  set tat   h'' = hp s'"
apply(induct rule: red_reds.inducts)
apply(fastforce dest: red_ext_new_thread_heap simp add: ta_upd_simps)+
done

lemma red_ta_Wakeup_no_Join_no_Lock_no_Interrupt:
  " convert_extTA extNTA,P,t  e, s -ta e', s'; Notified  set taw  WokenUp  set taw 
   collect_locks tal = {}  collect_cond_actions tac = {}  collect_interrupts tai = {}"
  and reds_ta_Wakeup_no_Join_no_Lock_no_Interrupt:
  " convert_extTA extNTA,P,t  es, s [-ta→] es', s'; Notified  set taw  WokenUp  set taw 
   collect_locks tal = {}  collect_cond_actions tac = {}  collect_interrupts tai = {}"
apply(induct rule: red_reds.inducts)
apply(auto simp add: ta_upd_simps dest: red_external_Wakeup_no_Join_no_Lock_no_Interrupt del: conjI)
done

lemma final_no_red:
  "final e  ¬ P,t  e, (h, l) -ta e', (h', l')"
by(auto elim: red.cases finalE)

lemma red_mthr: "multithreaded final_expr (mred P)"
by(unfold_locales)(auto dest: red_new_thread_heap)

end

sublocale J_heap_base < red_mthr: multithreaded
  "final_expr"
  "mred P"
  convert_RA
  for P
by(rule red_mthr)

context J_heap_base begin

abbreviation
  mredT :: 
  "'addr J_prog  ('addr,'thread_id,'addr expr × 'addr locals,'heap,'addr) state
   ('thread_id × ('addr, 'thread_id, 'addr expr × 'addr locals,'heap) Jinja_thread_action) 
   ('addr,'thread_id,'addr expr × 'addr locals,'heap,'addr) state  bool"
where
  "mredT P  red_mthr.redT P"

abbreviation
  mredT_syntax1 :: "'addr J_prog  ('addr,'thread_id,'addr expr × 'addr locals,'heap,'addr) state
                   'thread_id  ('addr, 'thread_id, 'addr expr × 'addr locals,'heap) Jinja_thread_action
                   ('addr,'thread_id,'addr expr × 'addr locals,'heap,'addr) state  bool"
                    ("_  _ -__ _" [50,0,0,0,50] 80)
where
  "mredT_syntax1 P s t ta s'  mredT P s (t, ta) s'"

abbreviation
  mRedT_syntax1 :: 
  "'addr J_prog
   ('addr,'thread_id,'addr expr × 'addr locals,'heap,'addr) state
   ('thread_id × ('addr, 'thread_id, 'addr expr × 'addr locals,'heap) Jinja_thread_action) list
   ('addr,'thread_id,'addr expr × 'addr locals,'heap,'addr) state  bool"
  ("_  _ -▹_→* _" [50,0,0,50] 80)
where
  "P  s -▹ttas→* s'  red_mthr.RedT P s ttas s'"

end

context J_heap begin

lemma redT_hext_incr:
  "P  s -tta s'  shr s  shr s'"
by(erule red_mthr.redT.cases)(auto dest!: red_hext_incr intro: hext_trans)

lemma RedT_hext_incr:
  assumes "P  s -▹tta→* s'"
  shows "shr s  shr s'"
using assms unfolding red_mthr.RedT_def
by(induct)(auto dest: redT_hext_incr intro: hext_trans)

end

subsection ‹Lifting @{term "tconf"} to multithreaded states›

context J_heap begin

lemma red_NewThread_Thread_Object:
  " convert_extTA extNTA,P,t  e, s -ta e', s'; NewThread t' x m  set tat  
   C. typeof_addr (hp s') (thread_id2addr t') = Class_type C  P  C * Thread"
  and reds_NewThread_Thread_Object:
  " convert_extTA extNTA,P,t  es, s [-ta→] es', s'; NewThread t' x m  set tat 
   C. typeof_addr (hp s') (thread_id2addr t') = Class_type C  P  C * Thread"
apply(induct rule: red_reds.inducts)
apply(fastforce dest: red_external_new_thread_exists_thread_object simp add: ta_upd_simps)+
done

lemma lifting_wf_tconf:
  "lifting_wf final_expr (mred P) (λt ex h. P,h  t √t)"
by(unfold_locales)(fastforce dest: red_hext_incr red_NewThread_Thread_Object elim!: tconf_hext_mono intro: tconfI)+

end

sublocale J_heap < red_tconf: lifting_wf final_expr "mred P" convert_RA "λt ex h. P,h  t √t"
by(rule lifting_wf_tconf)

subsection ‹Towards agreement between the framework semantics' lock state and the locks stored in the expressions›

primrec sync_ok :: "('a,'b,'addr) exp  bool"
  and sync_oks :: "('a,'b,'addr) exp list  bool"
where
  "sync_ok (new C) = True"
| "sync_ok (newA Ti) = sync_ok i"
| "sync_ok (Cast T e) = sync_ok e"
| "sync_ok (e instanceof T) = sync_ok e"
| "sync_ok (Val v) = True"
| "sync_ok (Var v) = True"
| "sync_ok (e «bop» e') = (sync_ok e  sync_ok e'  (contains_insync e'  is_val e))"
| "sync_ok (V := e) = sync_ok e"
| "sync_ok (ai) = (sync_ok a  sync_ok i  (contains_insync i  is_val a))"
| "sync_ok (AAss a i e) = (sync_ok a  sync_ok i  sync_ok e  (contains_insync i  is_val a)  (contains_insync e  is_val a  is_val i))"
| "sync_ok (a∙length) = sync_ok a"
| "sync_ok (eF{D}) = sync_ok e"
| "sync_ok (FAss e F D e') = (sync_ok e  sync_ok e'  (contains_insync e'  is_val e))"
| "sync_ok (e∙compareAndSwap(DF, e', e'')) = (sync_ok e  sync_ok e'  sync_ok e''  (contains_insync e'  is_val e)  (contains_insync e''  is_val e  is_val e'))"
| "sync_ok (em(pns)) = (sync_ok e  sync_oks pns  (contains_insyncs pns  is_val e))"
| "sync_ok ({V : T=vo; e}) = sync_ok e"
| "sync_ok (syncV (o') e) = (sync_ok o'  ¬ contains_insync e)"
| "sync_ok (insyncV (a) e) = sync_ok e"
| "sync_ok (e;;e') = (sync_ok e  ¬ contains_insync e')"
| "sync_ok (if (b) e else e') = (sync_ok b  ¬ contains_insync e  ¬ contains_insync e')"
| "sync_ok (while (b) e) = (¬ contains_insync b  ¬ contains_insync e)"
| "sync_ok (throw e) = sync_ok e"
| "sync_ok (try e catch(C v) e') = (sync_ok e  ¬ contains_insync e')"
| "sync_oks [] = True"
| "sync_oks (x # xs) = (sync_ok x  sync_oks xs  (contains_insyncs xs  is_val x))"

lemma sync_oks_append [simp]:
  "sync_oks (xs @ ys)  sync_oks xs  sync_oks ys  (contains_insyncs ys  (vs. xs = map Val vs))"
by(induct xs)(auto simp add: Cons_eq_map_conv)

lemma fixes e :: "('a,'b,'addr) exp" and es :: "('a,'b,'addr) exp list"
  shows not_contains_insync_sync_ok: "¬ contains_insync e  sync_ok e"
  and not_contains_insyncs_sync_oks: "¬ contains_insyncs es  sync_oks es"
by(induct e and es rule: sync_ok.induct sync_oks.induct)(auto)

lemma expr_locks_sync_ok: "(ad. expr_locks e ad = 0)  sync_ok e"
  and expr_lockss_sync_oks: "(ad. expr_lockss es ad = 0)  sync_oks es"
by(auto intro!: not_contains_insync_sync_ok not_contains_insyncs_sync_oks
        simp add: contains_insync_conv contains_insyncs_conv)

lemma sync_ok_extRet2J [simp, intro!]: "sync_ok e  sync_ok (extRet2J e va)"
by(cases va) auto

abbreviation
  sync_es_ok :: "('addr,'thread_id,('a,'b,'addr) exp×'c) thread_info  'heap  bool"
where
  "sync_es_ok  ts_ok (λt (e, x) m. sync_ok e)"

lemma sync_es_ok_blocks [simp]:
  " length pns = length Ts; length Ts = length vs   sync_ok (blocks pns Ts vs e) = sync_ok e"
by(induct pns Ts vs e rule: blocks.induct) auto

context J_heap_base begin

lemma assumes wf: "wf_J_prog P"
  shows red_preserve_sync_ok: " extTA,P,t  e, s -ta e', s'; sync_ok e   sync_ok e'"
  and reds_preserve_sync_oks: " extTA,P,t  es, s [-ta→] es', s'; sync_oks es   sync_oks es'"
proof(induct rule: red_reds.inducts)
  case (RedCall s a U M Ts T pns body D vs)
  from wf P  class_type_of U sees M: TsT = (pns, body) in D
  have "wf_mdecl wf_J_mdecl P D (M,Ts,T,(pns,body))"
    by(rule sees_wf_mdecl)
  then obtain T where "P,[thisClass D,pns[↦]Ts]  body :: T"
    by(auto simp add: wf_mdecl_def)
  hence "expr_locks body = (λad. 0)" by(rule WT_expr_locks)
  with ‹length vs = length pns ‹length Ts = length pns 
  have "expr_locks (blocks pns Ts vs body) = (λad. 0)"
    by(simp add: expr_locks_blocks)
  thus ?case by(auto intro: expr_locks_sync_ok)
qed(fastforce intro: not_contains_insync_sync_ok)+

lemma assumes wf: "wf_J_prog P"
  shows expr_locks_new_thread:
  " P,t  e, s -ta e', s'; NewThread t'' (e'', x'') h  set tat   expr_locks e'' = (λad. 0)"

  and expr_locks_new_thread':
  " P,t  es, s [-ta→] es', s'; NewThread t'' (e'', x'') h  set tat   expr_locks e'' = (λad. 0)"
proof(induct rule: red_reds.inducts)
  case (RedCallExternal s a U M Ts T D vs ta va h' ta' e' s')
  then obtain C fs a where subThread: "P  C * Thread" and ext: "extNTA2J P (C, run, a) = (e'', x'')"
    by(fastforce dest: red_external_new_thread_sub_thread)
  from sub_Thread_sees_run[OF wf subThread] obtain D pns body
    where sees: "P  C sees run: []Void = (pns, body) in D" by auto
  from sees_wf_mdecl[OF wf this] obtain T where "P,[this  Class D]  body :: T"
    by(auto simp add: wf_mdecl_def)
  hence "expr_locks body = (λad. 0)" by(rule WT_expr_locks)
  with sees ext show ?case by(auto simp add: extNTA2J_def)
qed(auto simp add: ta_upd_simps)

lemma assumes wf: "wf_J_prog P"
  shows red_new_thread_sync_ok: " P,t  e, s -ta e', s'; NewThread t'' (e'', x'') h''  set tat   sync_ok e''"
  and reds_new_thread_sync_ok: " P,t  es, s [-ta→] es', s'; NewThread t'' (e'', x'') h''  set tat   sync_ok e''"
by(auto dest!: expr_locks_new_thread[OF wf] expr_locks_new_thread'[OF wf] intro: expr_locks_sync_ok expr_lockss_sync_oks)

lemma lifting_wf_sync_ok: "wf_J_prog P  lifting_wf final_expr (mred P) (λt (e, x) m. sync_ok e)"
by(unfold_locales)(auto intro: red_preserve_sync_ok red_new_thread_sync_ok)

lemma redT_preserve_sync_ok:
  assumes red: "P  s -tta s'"
  shows " wf_J_prog P; sync_es_ok (thr s) (shr s)   sync_es_ok (thr s') (shr s')"
by(rule lifting_wf.redT_preserves[OF lifting_wf_sync_ok red])

lemma RedT_preserves_sync_ok:
  "wf_J_prog P; P  s -▹ttas→* s'; sync_es_ok (thr s) (shr s)
    sync_es_ok (thr s') (shr s')"
by(rule lifting_wf.RedT_preserves[OF lifting_wf_sync_ok])

lemma sync_es_ok_J_start_state:
  " wf_J_prog P; P  C sees M:TsT=(pns, body) in D; length Ts = length vs 
   sync_es_ok (thr (J_start_state P C M vs)) m"
apply(rule ts_okI)
apply(clarsimp simp add: start_state_def split_beta split: if_split_asm)
apply(drule (1) sees_wf_mdecl)
apply(clarsimp simp add: wf_mdecl_def)
apply(drule WT_expr_locks)
apply(rule expr_locks_sync_ok)
apply simp
done

end

text ‹Framework lock state agrees with locks stored in the expression›

definition lock_ok :: "('addr,'thread_id) locks  ('addr,'thread_id,('a, 'b,'addr) exp × 'x) thread_info  bool" where
  "ln. lock_ok ls ts  t. (case (ts t) of None     (l. has_locks (ls $ l) t = 0)
                                     | ((e, x), ln)  (l. has_locks (ls $ l) t + ln $ l = expr_locks e l))"

lemma lock_okI:
  " t l. ts t = None  has_locks (ls $ l) t = 0; t e x ln l. ts t = ((e, x), ln)  has_locks (ls $ l) t + ln $ l= expr_locks e l   lock_ok ls ts"
apply(fastforce simp add: lock_ok_def)
done

lemma lock_okE:
  " lock_ok ls ts;
     t. ts t = None  (l. has_locks (ls $ l) t = 0)  Q;
     t e x ln. ts t = ((e, x), ln)  (l. has_locks (ls $ l) t + ln $ l = expr_locks e l)  Q 
   Q"
by(fastforce simp add: lock_ok_def)

lemma lock_okD1:
  " lock_ok ls ts; ts t = None   l. has_locks (ls $ l) t = 0"
apply(simp add: lock_ok_def)
apply(erule_tac x="t" in allE)
apply(auto)
done

lemma lock_okD2:
  "ln.  lock_ok ls ts; ts t = ((e, x), ln)   l. has_locks (ls $ l) t + ln $ l = expr_locks e l"
apply(fastforce simp add: lock_ok_def)
done

lemma lock_ok_lock_thread_ok:
  assumes lock: "lock_ok ls ts"
  shows "lock_thread_ok ls ts"
proof(rule lock_thread_okI)
  fix l t
  assume lsl: "has_lock (ls $ l) t"
  show "xw. ts t = xw"
  proof(cases "ts t")
    case None
    with lock have "has_locks (ls $ l) t = 0"
      by(auto dest: lock_okD1)
    with lsl show ?thesis by simp
  next
    case (Some a) thus ?thesis by blast
  qed
qed

lemma (in J_heap_base) lock_ok_J_start_state:
  " wf_J_prog P; P  C sees M:TsT=(pns, body) in D; length Ts = length vs 
   lock_ok (locks (J_start_state P C M vs)) (thr (J_start_state P C M vs))"
apply(rule lock_okI)
apply(auto simp add: start_state_def split: if_split_asm)
apply(drule (1) sees_wf_mdecl)
apply(clarsimp simp add: wf_mdecl_def)
apply(drule WT_expr_locks)
apply(simp add: expr_locks_blocks)
done

subsection ‹Preservation of lock state agreement›

fun upd_expr_lock_action :: "int  lock_action  int"
where
  "upd_expr_lock_action i Lock = i + 1"
| "upd_expr_lock_action i Unlock = i - 1"
| "upd_expr_lock_action i UnlockFail = i"
| "upd_expr_lock_action i ReleaseAcquire = i"

fun upd_expr_lock_actions :: "int  lock_action list  int" where
  "upd_expr_lock_actions n [] = n"
| "upd_expr_lock_actions n (L # Ls) = upd_expr_lock_actions (upd_expr_lock_action n L) Ls"

lemma upd_expr_lock_actions_append [simp]:
  "upd_expr_lock_actions n (Ls @ Ls') = upd_expr_lock_actions (upd_expr_lock_actions n Ls) Ls'"
by(induct Ls arbitrary: n, auto)

definition upd_expr_locks :: "('l  int)  'l lock_actions  'l  int"
where "upd_expr_locks els las  λl. upd_expr_lock_actions (els l) (las $ l)"

lemma upd_expr_locks_iff [simp]:
  "upd_expr_locks els las l = upd_expr_lock_actions (els l) (las $ l)"
by(simp add: upd_expr_locks_def)

lemma upd_expr_lock_action_add [simp]:
  "upd_expr_lock_action (l + l') L = upd_expr_lock_action l L + l'"
by(cases L, auto)

lemma upd_expr_lock_actions_add [simp]:
  "upd_expr_lock_actions (l + l') Ls = upd_expr_lock_actions l Ls + l'"
by(induct Ls arbitrary: l, auto)

lemma upd_expr_locks_add [simp]:
  "upd_expr_locks (λa. x a + y a) las = (λa. upd_expr_locks x las a + y a)"
by(auto intro: ext)

lemma expr_locks_extRet2J [simp, intro!]: "expr_locks e = (λad. 0)  expr_locks (extRet2J e va) = (λad. 0)"
by(cases va) auto

lemma (in J_heap_base)
  assumes wf: "wf_J_prog P"
  shows red_update_expr_locks:
  " convert_extTA extNTA,P,t  e, s -ta e', s'; sync_ok e  
   upd_expr_locks (int o expr_locks e) tal = int o expr_locks e'"
  and reds_update_expr_lockss:
  " convert_extTA extNTA,P,t  es, s [-ta→] es', s'; sync_oks es 
   upd_expr_locks (int o expr_lockss es) tal = int o expr_lockss es'"
proof -
  have " convert_extTA extNTA,P,t  e, s -ta e', s'; sync_ok e  
        upd_expr_locks (λad. 0) tal = (λad. (int o expr_locks e') ad - (int o expr_locks e) ad)"
    and " convert_extTA extNTA,P,t  es, s [-ta→] es', s'; sync_oks es 
         upd_expr_locks (λad. 0) tal = (λad. (int o expr_lockss es') ad - (int o expr_lockss es) ad)"
  proof(induct rule: red_reds.inducts)
    case (RedCall s a U M Ts T pns body D vs)
    from wf P  class_type_of U sees M: TsT = (pns, body) in D
    have "wf_mdecl wf_J_mdecl P D (M,Ts,T,(pns,body))"
      by(rule sees_wf_mdecl)
    then obtain T where "P,[thisClass D,pns[↦]Ts]  body :: T"
      by(auto simp add: wf_mdecl_def)
    hence "expr_locks body = (λad. 0)" by(rule WT_expr_locks)
    with ‹length vs = length pns ‹length Ts = length pns 
    have "expr_locks (blocks pns Ts vs body) = (λad. 0)"
      by(simp add: expr_locks_blocks)
    thus ?case by(auto intro: expr_locks_sync_ok)
  next
    case RedCallExternal thus ?case
      by(auto simp add: fun_eq_iff contains_insync_conv contains_insyncs_conv finfun_upd_apply ta_upd_simps elim!: red_external.cases)
  qed(fastforce simp add: fun_eq_iff contains_insync_conv contains_insyncs_conv finfun_upd_apply ta_upd_simps)+
  hence " convert_extTA extNTA,P,t  e, s -ta e', s'; sync_ok e 
         upd_expr_locks (λad. 0 + (int  expr_locks e) ad) tal = int  expr_locks e'"
    and " convert_extTA extNTA,P,t  es, s [-ta→] es', s'; sync_oks es 
         upd_expr_locks (λad. 0 + (int  expr_lockss es) ad) tal = int  expr_lockss es'"
    by(auto intro: ext simp only: upd_expr_locks_add)
  thus " convert_extTA extNTA,P,t  e, s -ta e', s'; sync_ok e 
        upd_expr_locks (int o expr_locks e) tal = int o expr_locks e'"
    and " convert_extTA extNTA,P,t  es, s [-ta→] es', s'; sync_oks es 
         upd_expr_locks (int o expr_lockss es) tal = int o expr_lockss es'"
    by(auto simp add: o_def)
qed

definition lock_expr_locks_ok :: "'t FWState.lock  't  nat  int  bool" where
  "lock_expr_locks_ok l t n i  (i = int (has_locks l t) + int n)  i  0"

lemma upd_lock_upd_expr_lock_action_preserve_lock_expr_locks_ok:
  assumes lao: "lock_action_ok l t L"
  and lelo: "lock_expr_locks_ok l t n i"
  shows "lock_expr_locks_ok (upd_lock l t L) t (upd_threadR n l t L) (upd_expr_lock_action i L)"
proof -
  from lelo have i: "i  0"
    and hl: "i = int (has_locks l t) + int n"
    by(auto simp add: lock_expr_locks_ok_def)
  from lelo
  show ?thesis
  proof(cases L)
    case Lock
    with lao have "may_lock l t" by(simp)
    with hl have "has_locks (lock_lock l t) t = (Suc (has_locks l t))" by(auto)
    with Lock i hl show ?thesis
      by(simp add: lock_expr_locks_ok_def)
  next
    case Unlock
    with lao have "has_lock l t" by simp
    then obtain n' 
      where hl': "has_locks l t = Suc n'"
      by(auto dest: has_lock_has_locks_Suc)
    hence "has_locks (unlock_lock l) t = n'" by simp
    with Unlock i hl hl' show ?thesis
      by(simp add: lock_expr_locks_ok_def)
  qed(auto simp add: lock_expr_locks_ok_def)
qed

lemma upd_locks_upd_expr_lock_preserve_lock_expr_locks_ok:
  " lock_actions_ok l t Ls; lock_expr_locks_ok l t n i 
   lock_expr_locks_ok (upd_locks l t Ls) t (upd_threadRs n l t Ls) (upd_expr_lock_actions i Ls)"
by(induct Ls arbitrary: l i n)(auto intro: upd_lock_upd_expr_lock_action_preserve_lock_expr_locks_ok)


definition ls_els_ok :: "('addr,'thread_id) locks  'thread_id  ('addr ⇒f nat)  ('addr  int)  bool" where
  "ln. ls_els_ok ls t ln els  l. lock_expr_locks_ok (ls $ l) t (ln $ l) (els l)"

lemma ls_els_okI:
  "ln. (l. lock_expr_locks_ok (ls $ l) t (ln $ l) (els l))  ls_els_ok ls t ln els"
by(auto simp add: ls_els_ok_def)

lemma ls_els_okE:
  "ln.  ls_els_ok ls t ln els; l. lock_expr_locks_ok (ls $ l) t (ln $ l) (els l)  P   P"
by(auto simp add: ls_els_ok_def)

lemma ls_els_okD:
  "ln. ls_els_ok ls t ln els  lock_expr_locks_ok (ls $ l) t (ln $ l) (els l)"
by(auto simp add: ls_els_ok_def)

lemma redT_updLs_upd_expr_locks_preserves_ls_els_ok:  
 "ln.  ls_els_ok ls t ln els; lock_ok_las ls t las 
   ls_els_ok (redT_updLs ls t las) t (redT_updLns ls t ln las) (upd_expr_locks els las)"
by(auto intro!: ls_els_okI upd_locks_upd_expr_lock_preserve_lock_expr_locks_ok elim!: ls_els_okE simp add: redT_updLs_def lock_ok_las_def)

lemma sync_ok_redT_updT: 
  assumes "sync_es_ok ts h"
  and nt: "t e x h''. ta = NewThread t (e, x) h''  sync_ok e"
  shows "sync_es_ok (redT_updT ts ta) h'"
using assms
proof(cases ta)
  case (NewThread T x m)
  obtain E X where [simp]: "x = (E, X)" by (cases x, auto)
  with NewThread have "sync_ok E" by(simp)(rule nt)
  with NewThread ‹sync_es_ok ts h show ?thesis
    apply -
    apply(rule ts_okI)
    apply(case_tac "t=T")
    by(auto dest: ts_okD)
qed(auto intro: ts_okI dest: ts_okD)


lemma sync_ok_redT_updTs: 
  " sync_es_ok ts h; t e x h. NewThread t (e, x) h  set tas  sync_ok e 
   sync_es_ok (redT_updTs ts tas) h'"
proof(induct tas arbitrary: ts)
  case Nil thus ?case by(auto intro: ts_okI dest: ts_okD)
next
  case (Cons TA TAS TS)
  note IH = ts. sync_es_ok ts h; t e x h''. NewThread t (e, x) h''  set TAS  sync_ok e 
             sync_es_ok (redT_updTs ts TAS) h'
  note nt = t e x h. NewThread t (e, x) h  set (TA # TAS)  sync_ok e
  from ‹sync_es_ok TS h nt
  have "sync_es_ok (redT_updT TS TA) h"
    by(auto elim!: sync_ok_redT_updT)
  hence "sync_es_ok (redT_updTs (redT_updT TS TA) TAS) h'"
    by(rule IH)(auto intro: nt)
  thus ?case by simp
qed

lemma lock_ok_thr_updI:
  "ln.  lock_ok ls ts; ts t = ((e, xs), ln); expr_locks e = expr_locks e' 
   lock_ok ls (ts(t  ((e', xs'), ln)))"
by(rule lock_okI)(auto split: if_split_asm dest: lock_okD2 lock_okD1)

context J_heap_base begin 

lemma redT_preserves_lock_ok:
  assumes wf: "wf_J_prog P"
  and "P  s -tta s'"
  and "lock_ok (locks s) (thr s)"
  and "sync_es_ok (thr s) (shr s)"
  shows "lock_ok (locks s') (thr s')"
proof -
  obtain ls ts h ws "is" where s [simp]: "s = (ls, (ts, h), ws, is)" by(cases s) fastforce
  obtain ls' ts' h' ws' is' where s' [simp]: "s' = (ls', (ts', h'), ws', is')" by(cases s') fastforce
  from assms have redT: "P  (ls, (ts, h), ws, is) -tta (ls', (ts', h'), ws', is')"
    and loes: "lock_ok ls ts"
    and aoes: "sync_es_ok ts h" by auto
  from redT have "lock_ok ls' ts'"
  proof(cases rule: red_mthr.redT_elims)
    case (normal a a' m')
    moreover obtain e x where "a = (e, x)" by (cases a, auto)
    moreover obtain e' x' where "a' = (e', x')" by (cases a', auto)
    ultimately have P: "P,t  e,(h, x) -ta e',(m', x')"
      and est: "ts t = ((e, x), no_wait_locks)"
      and lota: "lock_ok_las ls t tal"
      and cctta: "thread_oks ts tat"
      and ls': "ls' = redT_updLs ls t tal"
      and s': "ts' = redT_updTs ts tat(t  ((e', x'), redT_updLns ls t no_wait_locks tal))"
      by auto
    let ?ts' = "redT_updTs ts tat(t  ((e', x'), redT_updLns ls t no_wait_locks tal))"
    from est aoes have aoe: "sync_ok e" by(auto dest: ts_okD)
    from aoe P have aoe': "sync_ok e'" by(auto dest: red_preserve_sync_ok[OF wf])
    from aoes red_new_thread_sync_ok[OF wf P]
    have "sync_es_ok (redT_updTs ts tat) h'"
      by(rule sync_ok_redT_updTs)
    with aoe' have aoes': "sync_es_ok ?ts' m'"
      by(auto intro!: ts_okI dest: ts_okD split: if_split_asm)
    have "lock_ok ls' ?ts'"
    proof(rule lock_okI)
      fix t'' l
      assume "?ts' t'' = None"
      hence "ts t'' = None"
        by(auto split: if_split_asm intro: redT_updTs_None)
      with loes have "has_locks (ls $ l) t'' = 0"
        by(auto dest: lock_okD1)
      moreover from ?ts' t'' = None› 
      have "t  t''" by(simp split: if_split_asm)
      ultimately show "has_locks (ls' $ l) t'' = 0"
        by(simp add: red_mthr.redT_has_locks_inv[OF redT])
    next
      fix t'' e'' x'' l ln''
      assume ts't'': "?ts' t'' = ((e'', x''), ln'')"
      with aoes' have aoe'': "sync_ok e''" by(auto dest: ts_okD)
      show "has_locks (ls' $ l) t'' + ln'' $ l = expr_locks e'' l"
      proof(cases "t = t''")
        case True
        note tt'' = t = t''
        with ts't'' have  e'': "e'' = e'" and x'': "x'' = x'"
          and ln'': "ln'' = redT_updLns ls t no_wait_locks tal" by auto
        have "ls_els_ok ls t no_wait_locks (int o expr_locks e)"
        proof(rule ls_els_okI)
          fix l
          note lock_okD2[OF loes, OF est]
          thus "lock_expr_locks_ok (ls $ l) t (no_wait_locks $ l) ((int  expr_locks e) l)"
            by(simp add: lock_expr_locks_ok_def)
        qed
        hence "ls_els_ok (redT_updLs ls t tal) t (redT_updLns ls t no_wait_locks tal) (upd_expr_locks (int o expr_locks e) tal)"
          by(rule redT_updLs_upd_expr_locks_preserves_ls_els_ok[OF _ lota])
        hence "ls_els_ok (redT_updLs ls t tal) t (redT_updLns ls t no_wait_locks tal) (int o expr_locks e')"
          by(simp only: red_update_expr_locks[OF wf P aoe])
        thus ?thesis using ls' e'' tt'' ln''
          by(auto dest: ls_els_okD[where l = l] simp: lock_expr_locks_ok_def)
      next
        case False
        note tt'' = t  t''
        from lota have lao: "lock_actions_ok (ls $ l) t (tal $ l)"
          by(simp add: lock_ok_las_def)
        show ?thesis
        proof(cases "ts t''")
          case None
          with est ts't'' tt'' cctta
          obtain m where "NewThread t'' (e'', x'') m  set tat" and ln'': "ln'' = no_wait_locks"
            by(auto dest: redT_updTs_new_thread)
          moreover with P have "m' = m" by(auto dest: red_new_thread_heap)
          ultimately have "NewThread t'' (e'', x'') m'  set tat" by simp
          with wf P ln'' have "expr_locks e'' = (λad. 0)"
            by -(rule expr_locks_new_thread)
          hence elel: "expr_locks e'' l = 0" by simp
          from loes None  have "has_locks (ls $ l) t'' = 0"
            by(auto dest: lock_okD1)
          moreover note lock_actions_ok_has_locks_upd_locks_eq_has_locks[OF lao tt''[symmetric]]
          ultimately have "has_locks (redT_updLs ls t tal $ l) t'' = 0"
            by(auto simp add: fun_eq_iff)
          with elel ls' ln'' show ?thesis by(auto)
        next
          case (Some a)
          then obtain E X LN where est'': "ts t'' = ((E, X), LN)" by(cases a, auto)
          with loes have IH: "has_locks (ls $ l) t'' + LN $ l = expr_locks E l"
            by(auto dest: lock_okD2)
          from est est'' tt'' cctta have "?ts' t'' = ((E, X), LN)"
            by(simp)(rule redT_updTs_Some, simp_all)
          with ts't'' have e'': "E = e''" and x'': "X = x''"
            and ln'': "ln'' = LN" by(simp_all)
          with lock_actions_ok_has_locks_upd_locks_eq_has_locks[OF lao tt''[symmetric]] IH ls'
          show ?thesis by(clarsimp simp add: redT_updLs_def fun_eq_iff)
        qed
      qed
    qed
    with s' show ?thesis by simp
  next
    case (acquire a ln n)
    hence [simp]: "ta = (K$ [], [], [], [], [], convert_RA ln)" "ws' = ws" "h' = h" 
      and ls': "ls' = acquire_all ls t ln"
      and ts': "ts' = ts(t  (a, no_wait_locks))"
      and "ts t = (a, ln)"
      and "may_acquire_all ls t ln"
      by auto
    obtain e x where [simp]: "a = (e, x)" by (cases a, auto)
    from ts' have ts': "ts' = ts(t  ((e, x), no_wait_locks))" by simp
    from ts t = (a, ln) have tst: "ts t = ((e, x), ln)" by simp
    show ?thesis
    proof(rule lock_okI)
      fix t'' l
      assume rtutes: "ts' t'' = None"
      with ts' have tst'': "ts t'' = None"
        by(simp split: if_split_asm)
      with tst have tt'': "t  t''" by auto
      from tst'' loes have "has_locks (ls $ l) t'' = 0"
        by(auto dest: lock_okD1)
      thus "has_locks (ls' $ l) t'' = 0"
        by(simp add: red_mthr.redT_has_locks_inv[OF redT tt''])
    next
      fix t'' e'' x'' ln'' l
      assume ts't'': "ts' t'' = ((e'', x''), ln'')"
      show "has_locks (ls' $ l) t'' + ln'' $ l = expr_locks e'' l"
      proof(cases "t = t''")
        case True
        note [simp] = this
        with ts't'' ts' tst
        have [simp]: "ln'' = no_wait_locks" "e = e''" by auto
        from tst loes have "has_locks (ls $ l) t + ln $ l = expr_locks e l"
          by(auto dest: lock_okD2)
        show ?thesis
        proof(cases "ln $ l > 0")
          case True
          with ‹may_acquire_all ls t ln ls' have "may_lock (ls $ l) t"
            by(auto elim: may_acquire_allE)
          with ls'
          have "has_locks (ls' $ l) t = has_locks (ls $ l) t + ln $ l"
            by(simp add: has_locks_acquire_locks_conv)
          with ‹has_locks (ls $ l) t + ln $ l = expr_locks e l
          show ?thesis by(simp)
        next
          case False
          hence "ln $ l = 0" by simp
          with ls' have "has_locks (ls' $ l) t = has_locks (ls $ l) t"
            by(simp)
          with ‹has_locks (ls $ l) t + ln $ l = expr_locks e l ln $ l = 0
          show ?thesis by(simp)
        qed
      next
        case False
        with ts' ts't'' have tst'': "ts t'' = ((e'', x''), ln'')" by(simp)
        with loes have "has_locks (ls $ l) t'' + ln'' $ l = expr_locks e'' l"
          by(auto dest: lock_okD2)
        show ?thesis
        proof(cases "ln $ l > 0")
          case False
          with t  t'' ls'
          have "has_locks (ls' $ l) t'' = has_locks (ls $ l) t''" by(simp)
          with ‹has_locks (ls $ l) t'' + ln'' $ l = expr_locks e'' l
          show ?thesis by(simp)
        next
          case True
          with ‹may_acquire_all ls t ln have "may_lock (ls $ l) t"
            by(auto elim: may_acquire_allE)
          with ls' t  t'' have "has_locks (ls' $ l) t'' = has_locks (ls $ l) t''"
            by(simp add: has_locks_acquire_locks_conv')
          with ls' ‹has_locks (ls $ l) t'' + ln'' $ l = expr_locks e'' l
          show ?thesis by(simp)
        qed
      qed
    qed
  qed
  thus ?thesis by simp
qed

lemma invariant3p_sync_es_ok_lock_ok:
  assumes wf: "wf_J_prog P"
  shows "invariant3p (mredT P) {s. sync_es_ok (thr s) (shr s)  lock_ok (locks s) (thr s)}"
apply(rule invariant3pI)
apply clarify
apply(rule conjI)
 apply(rule lifting_wf.redT_preserves[OF lifting_wf_sync_ok[OF wf]], blast)
 apply(assumption)
apply(erule (2) redT_preserves_lock_ok[OF wf])
done

lemma RedT_preserves_lock_ok:
  assumes wf: "wf_J_prog P"
  and Red: "P  s -▹ttas→* s'"
  and ae: "sync_es_ok (thr s) (shr s)"
  and loes: "lock_ok (locks s) (thr s)"
  shows "lock_ok (locks s') (thr s')"
using invariant3p_rtrancl3p[OF invariant3p_sync_es_ok_lock_ok[OF wf] Red[unfolded red_mthr.RedT_def]] ae loes
by simp

end

subsection ‹Determinism›

context J_heap_base begin

lemma
  fixes final
  assumes det: "deterministic_heap_ops"
  shows red_deterministic:
  " convert_extTA extTA,P,t  e, (shr s, xs) -ta e', s'; 
     convert_extTA extTA,P,t  e, (shr s, xs) -ta' e'', s'';
     final_thread.actions_ok final s t ta; final_thread.actions_ok final s t ta'  
   ta = ta'  e' = e''  s' = s''"
  and reds_deterministic:
  " convert_extTA extTA,P,t  es, (shr s, xs) [-ta→] es', s'; 
     convert_extTA extTA,P,t  es, (shr s, xs) [-ta'→] es'', s'';
     final_thread.actions_ok final s t ta; final_thread.actions_ok final s t ta'  
   ta = ta'  es' = es''  s' = s''"
proof(induct e "(shr s, xs)" ta e' s' and es "(shr s, xs)" ta es' s' arbitrary: e'' s'' xs and es'' s'' xs rule: red_reds.inducts)
  case RedNew
  thus ?case by(auto elim!: red_cases dest: deterministic_heap_ops_allocateD[OF det])
next
  case RedNewArray
  thus ?case by(auto elim!: red_cases dest: deterministic_heap_ops_allocateD[OF det])
next
  case RedCall thus ?case
    by(auto elim!: red_cases dest: sees_method_fun simp add: map_eq_append_conv)
next
  case RedCallExternal thus ?case
    by(auto elim!: red_cases dest: red_external_deterministic[OF det] simp add: final_thread.actions_ok_iff map_eq_append_conv dest: sees_method_fun)
next
  case RedCallNull thus ?case by(auto elim!: red_cases dest: sees_method_fun simp add: map_eq_append_conv)
next
  case CallThrowParams thus ?case
    by(auto elim!: red_cases dest: sees_method_fun simp add: map_eq_append_conv append_eq_map_conv append_eq_append_conv2 reds_map_Val_Throw Cons_eq_append_conv append_eq_Cons_conv)
qed(fastforce elim!: red_cases reds_cases dest: deterministic_heap_ops_readD[OF det] deterministic_heap_ops_writeD[OF det] iff: reds_map_Val_Throw)+

lemma red_mthr_deterministic:
  assumes det: "deterministic_heap_ops"
  shows "red_mthr.deterministic P UNIV"
proof(rule red_mthr.determisticI)
  fix s t x ta' x' m' ta'' x'' m''
  assume "thr s t = (x, no_wait_locks)"
    and red: "mred P t (x, shr s) ta' (x', m')" "mred P t (x, shr s) ta'' (x'', m'')"
    and aok: "red_mthr.actions_ok s t ta'" "red_mthr.actions_ok s t ta''"
  moreover obtain e xs where [simp]: "x = (e, xs)" by(cases x)
  moreover obtain e' xs' where [simp]: "x' = (e', xs')" by(cases x')
  moreover obtain e'' xs'' where [simp]: "x'' = (e'', xs'')" by(cases x'')
  ultimately have "extTA2J P,P,t  e,(shr s, xs) -ta' e',(m', xs')"
    and "extTA2J P,P,t  e,(shr s, xs) -ta'' e'',(m'', xs'')"
    by simp_all
  from red_deterministic[OF det this aok]
  show "ta' = ta''  x' = x''  m' = m''" by simp
qed simp

end

end

Theory WellTypeRT

(*  Title:      JinjaThreads/J/WellTypeRT.thy
    Author:     Tobias Nipkow, Andreas Lochbihler
*)

section ‹Runtime Well-typedness›

theory WellTypeRT
imports 
  WellType
  JHeap
begin

context J_heap_base begin

inductive WTrt :: "'addr J_prog  'heap  env  'addr expr  ty  bool"
  and WTrts :: "'addr J_prog  'heap  env  'addr expr list  ty list  bool"
  for P :: "'addr J_prog" and h :: "'heap"
  where

  WTrtNew:
    "is_class P C   WTrt P h E (new C) (Class C)"

| WTrtNewArray:
    " WTrt P h E e Integer; is_type P (T⌊⌉) 
     WTrt P h E (newA Te) (T⌊⌉)"

| WTrtCast:
    " WTrt P h E e T; is_type P U   WTrt P h E (Cast U e) U"

| WTrtInstanceOf:
    " WTrt P h E e T; is_type P U   WTrt P h E (e instanceof U) Boolean"

| WTrtVal:
    "typeofh v = Some T  WTrt P h E (Val v) T"

| WTrtVar:
    "E V = Some T   WTrt P h E (Var V) T"

| WTrtBinOp:
    " WTrt P h E e1 T1; WTrt P h E e2 T2; P  T1«bop»T2 : T 
   WTrt P h E (e1 «bop» e2) T"

| WTrtLAss:
    " E V = Some T; WTrt P h E e T'; P  T'  T 
      WTrt P h E (V:=e) Void"

| WTrtAAcc:
    " WTrt P h E a (T⌊⌉); WTrt P h E i Integer 
     WTrt P h E (ai) T"

| WTrtAAccNT:
    " WTrt P h E a NT; WTrt P h E i Integer 
     WTrt P h E (ai) T"

| WTrtAAss:
    "  WTrt P h E a (T⌊⌉); WTrt P h E i Integer; WTrt P h E e T' 
     WTrt P h E (ai := e) Void"

| WTrtAAssNT:
    "  WTrt P h E a NT; WTrt P h E i Integer; WTrt P h E e T' 
     WTrt P h E (ai := e) Void"

| WTrtALength:
  "WTrt P h E a (T⌊⌉)  WTrt P h E (a∙length) Integer"

| WTrtALengthNT:
  "WTrt P h E a NT  WTrt P h E (a∙length) T"

| WTrtFAcc:
    " WTrt P h E e U; class_type_of' U = C; P  C has F:T (fm) in D  
    WTrt P h E (eF{D}) T"

| WTrtFAccNT:
    "WTrt P h E e NT  WTrt P h E (eF{D}) T"

| WTrtFAss:
    " WTrt P h E e1 U; class_type_of' U = C;  P  C has F:T (fm) in D; WTrt P h E e2 T2;  P  T2  T 
     WTrt P h E (e1F{D}:=e2) Void"

| WTrtFAssNT:
    " WTrt P h E e1 NT; WTrt P h E e2 T2 
     WTrt P h E (e1F{D}:=e2) Void"

| WTrtCAS:
  " WTrt P h E e1 U; class_type_of' U = C; P  C has F:T (fm) in D; volatile fm;
     WTrt P h E e2 T2; P  T2  T; WTrt P h E e3 T3; P  T3  T 
   WTrt P h E (e1∙compareAndSwap(DF, e2, e3)) Boolean"

| WTrtCASNT:
  " WTrt P h E e1 NT; WTrt P h E e2 T2; WTrt P h E e3 T3 
   WTrt P h E (e1∙compareAndSwap(DF, e2, e3)) Boolean"

| WTrtCall:
    " WTrt P h E e U; class_type_of' U = C; P  C sees M:Ts  T = meth in D;
       WTrts P h E es Ts'; P  Ts' [≤] Ts 
     WTrt P h E (eM(es)) T"

| WTrtCallNT:
    " WTrt P h E e NT; WTrts P h E es Ts 
     WTrt P h E (eM(es)) T"

| WTrtBlock:
    " WTrt P h (E(VT)) e T'; case vo of None  True | v  T'. typeofh v = T'  P  T'  T 
   WTrt P h E {V:T=vo; e} T'"

| WTrtSynchronized:
    " WTrt P h E o' T; is_refT T; WTrt P h E e T' 
     WTrt P h E (sync(o') e) T'"

| WTrtInSynchronized:
    " WTrt P h E (addr a) T; WTrt P h E e T' 
     WTrt P h E (insync(a) e) T'"

| WTrtSeq:
    " WTrt P h E e1 T1; WTrt P h E e2 T2 
     WTrt P h E (e1;;e2) T2"

| WTrtCond:
    " WTrt P h E e Boolean; WTrt P h E e1 T1; WTrt P h E e2 T2; P  lub(T1, T2) = T 
     WTrt P h E (if (e) e1 else e2) T"

| WTrtWhile:
    " WTrt P h E e Boolean; WTrt P h E c T 
     WTrt P h E (while(e) c) Void"

| WTrtThrow:
    " WTrt P h E e T; P  T  Class Throwable 
     WTrt P h E (throw e) T'"

| WTrtTry:
    " WTrt P h E e1 T1; WTrt P h (E(V  Class C)) e2 T2; P  T1  T2 
     WTrt P h E (try e1 catch(C V) e2) T2"

| WTrtNil: "WTrts P h E [] []"

| WTrtCons: " WTrt P h E e T; WTrts P h E es Ts   WTrts P h E (e # es) (T # Ts)"

abbreviation
  WTrt_syntax :: "'addr J_prog  env  'heap  'addr expr  ty  bool" ("_,_,_  _ : _"   [51,51,51]50)
where
  "P,E,h  e : T  WTrt P h E e T"

abbreviation
  WTrts_syntax :: "'addr J_prog  env  'heap  'addr expr list  ty list  bool" ("_,_,_  _ [:] _"   [51,51,51]50)
where
  "P,E,h  es [:] Ts  WTrts P h E es Ts"

lemmas [intro!] =
  WTrtNew WTrtNewArray WTrtCast WTrtInstanceOf WTrtVal WTrtVar WTrtBinOp WTrtLAss
  WTrtBlock WTrtSynchronized WTrtInSynchronized WTrtSeq WTrtCond WTrtWhile
  WTrtThrow WTrtTry WTrtNil WTrtCons

lemmas [intro] =
  WTrtFAcc WTrtFAccNT WTrtFAss WTrtFAssNT WTrtCall WTrtCallNT
  WTrtAAcc WTrtAAccNT WTrtAAss WTrtAAssNT WTrtALength WTrtALengthNT 

subsection‹Easy consequences›

inductive_simps WTrts_iffs [iff]:
  "P,E,h  [] [:] Ts"
  "P,E,h  e#es [:] T#Ts"
  "P,E,h  (e#es) [:] Ts"

lemma WTrts_conv_list_all2: "P,E,h  es [:] Ts = list_all2 (WTrt P h E) es Ts"
by(induct es arbitrary: Ts)(auto simp add: list_all2_Cons1 elim: WTrts.cases)

lemma [simp]: "(P,E,h  es1 @ es2 [:] Ts) =
  (Ts1 Ts2. Ts = Ts1 @ Ts2  P,E,h  es1 [:] Ts1 & P,E,h  es2[:]Ts2)"
by(auto simp add: WTrts_conv_list_all2 list_all2_append1 dest: list_all2_lengthD[symmetric])

inductive_simps WTrt_iffs [iff]:
  "P,E,h  Val v : T"
  "P,E,h  Var v : T"
  "P,E,h  e1;;e2 : T2"
  "P,E,h  {V:T=vo; e} : T'"

inductive_cases WTrt_elim_cases[elim!]:
  "P,E,h  newA Ti : U"
  "P,E,h  v :=e : T"
  "P,E,h  if (e) e1 else e2 : T"
  "P,E,h  while(e) c : T"
  "P,E,h  throw e : T"
  "P,E,h  try e1 catch(C V) e2 : T"
  "P,E,h  Cast D e : T"
  "P,E,h  e instanceof U : T"
  "P,E,h  ai : T"
  "P,E,h  ai := e : T"
  "P,E,h  a∙length : T"
  "P,E,h  eF{D} : T"
  "P,E,h  eF{D} := v : T"
  "P,E,h  e∙compareAndSwap(DF, e2, e3) : T"
  "P,E,h  e1 «bop» e2 : T"
  "P,E,h  new C : T"
  "P,E,h  eM(es) : T"
  "P,E,h  sync(o') e : T"
  "P,E,h  insync(a) e : T"

subsection‹Some interesting lemmas›

lemma WTrts_Val[simp]:
 "P,E,h  map Val vs [:] Ts  map (typeofh) vs = map Some Ts"
by(induct vs arbitrary: Ts) auto

lemma WTrt_env_mono: "P,E,h  e : T  (E'. E m E'  P,E',h  e : T)"
  and WTrts_env_mono: "P,E,h  es [:] Ts  (E'. E m E'  P,E',h  es [:] Ts)"
apply(induct rule: WTrt_WTrts.inducts)
apply(simp add: WTrtNew)
apply(fastforce simp: WTrtNewArray)
apply(fastforce simp: WTrtCast)
apply(fastforce simp: WTrtInstanceOf)
apply(fastforce simp: WTrtVal)
apply(simp add: WTrtVar map_le_def dom_def)
apply(fastforce simp add: WTrtBinOp)
apply(force simp: map_le_def)
apply(force simp: WTrtAAcc)
apply(force simp: WTrtAAccNT)
apply(rule WTrtAAss, fastforce, blast, blast)
apply(fastforce)
apply(rule WTrtALength, blast)
apply(blast)
apply(fastforce simp: WTrtFAcc)
apply(simp add: WTrtFAccNT)
apply(fastforce simp: WTrtFAss)
apply(fastforce simp: WTrtFAssNT)
apply(fastforce simp: WTrtCAS)
apply(fastforce simp: WTrtCASNT)
apply(fastforce simp: WTrtCall)
apply(fastforce simp: WTrtCallNT)
apply(fastforce simp: map_le_def)
apply(fastforce)
apply(fastforce)
apply(fastforce)
apply(fastforce)
apply(fastforce simp: WTrtSeq)
apply(fastforce simp: WTrtCond)
apply(fastforce simp: WTrtWhile)
apply(fastforce simp: WTrtThrow)
apply(auto simp: WTrtTry map_le_def dom_def)
done

lemma WT_implies_WTrt: "P,E  e :: T  P,E,h  e : T"
  and WTs_implies_WTrts: "P,E  es [::] Ts  P,E,h  es [:] Ts"
apply(induct rule: WT_WTs.inducts)
apply fast
apply fast
apply fast
apply fast
apply(fastforce dest:typeof_lit_typeof)
apply(simp)
apply(fastforce intro: WT_binop_WTrt_binop)
apply(fastforce)
apply(erule WTrtAAcc)
apply(assumption)
apply(erule WTrtAAss)
apply(assumption)+
apply(erule WTrtALength)
apply(fastforce intro: has_visible_field)
apply(fastforce simp: WTrtFAss dest: has_visible_field)
apply(fastforce simp: WTrtCAS dest: has_visible_field)
apply(fastforce simp: WTrtCall)
apply(clarsimp simp del: fun_upd_apply, blast intro: typeof_lit_typeof)
apply(fastforce)+
done

lemma wt_blocks:
 "E.  length Vs = length Ts; length vs = length Ts  
       (P,E,h  blocks Vs Ts vs e : T) =
       (P,E(Vs[↦]Ts),h  e:T  (Ts'. map (typeofh) vs = map Some Ts'  P  Ts' [≤] Ts))"
apply(induct Vs Ts vs e rule:blocks.induct)
apply (force)
apply simp_all
done

end

context J_heap begin

lemma WTrt_hext_mono: "P,E,h  e : T  h  h'  P,E,h'  e : T"
  and WTrts_hext_mono: "P,E,h  es [:] Ts  h  h'  P,E,h'  es [:] Ts"
apply(induct rule: WTrt_WTrts.inducts)
apply(simp add: WTrtNew)
apply(fastforce simp: WTrtNewArray)
apply(fastforce simp: WTrtCast)
apply(fastforce simp: WTrtInstanceOf)
apply(fastforce simp: WTrtVal dest:hext_typeof_mono)
apply(simp add: WTrtVar)
apply(fastforce simp add: WTrtBinOp)
apply(fastforce simp add: WTrtLAss)
apply fastforce
apply fastforce
apply fastforce
apply fastforce
apply fastforce
apply fastforce
apply(fast)
apply(simp add: WTrtFAccNT)
apply(fastforce simp: WTrtFAss del:WTrt_WTrts.intros WTrt_elim_cases)
apply(fastforce simp: WTrtFAssNT)
apply(fastforce simp: WTrtCAS)
apply(fastforce simp: WTrtCASNT)
apply(fastforce simp: WTrtCall)
apply(fastforce simp: WTrtCallNT)
apply(fastforce intro: hext_typeof_mono)
apply fastforce+
done

end

end

Theory Progress

(*  Title:      JinjaThreads/J/SmallProgress.thy
    Author:     Tobias Nipkow, Andreas Lochbihler
*)

section ‹Progress of Small Step Semantics›

theory Progress
imports
  WellTypeRT
  DefAss
  SmallStep
  "../Common/ExternalCallWF"
  WWellForm
begin

context J_heap begin

lemma final_addrE [consumes 3, case_names addr Throw]:
  " P,E,h  e : T; class_type_of' T = U; final e;
    a. e = addr a  R;
    a. e = Throw a  R   R"
apply(auto elim!: final.cases)
apply(case_tac v)
apply auto
done

lemma finalRefE [consumes 3, case_names null Class Array Throw]:
 " P,E,h  e : T; is_refT T; final e;
   e = null  R;
   a C.  e = addr a; T = Class C   R;
   a U.  e = addr a; T = U⌊⌉   R;
   a. e = Throw a  R   R"
apply(auto simp:final_iff)
apply(case_tac v)
apply(auto elim!: is_refT.cases)
done

end

theorem (in J_progress) red_progress:
  assumes wf: "wwf_J_prog P" and hconf: "hconf h"
  shows progress: " P,E,h  e : T; 𝒟 e dom l; ¬ final e   e' s' ta. extTA,P,t  e,(h,l) -ta e',s'"
  and progresss: " P,E,h  es [:] Ts; 𝒟s es dom l; ¬ finals es   es' s' ta. extTA,P,t  es,(h,l) [-ta→] es',s'"
proof (induct arbitrary: l and l rule:WTrt_WTrts.inducts)
  case (WTrtNew C)
  thus ?case using WTrtNew
    by(cases "allocate h (Class_type C) = {}")(fastforce intro: RedNewFail RedNew)+
next
  case (WTrtNewArray E e T l)
  have IH: "l. 𝒟 e dom l; ¬ final e  e' s' tas. extTA,P,t  e,(h,l) -tas e', s'"
   and D: "𝒟 (newA Te) dom l"
   and ei: "P,E,h  e : Integer" by fact+
  from D have De: "𝒟 e dom l" by auto
  show ?case
  proof cases 
    assume "final e"
    thus ?thesis
    proof (rule finalE)
      fix v
      assume e [simp]: "e = Val v"
      with ei have "typeofh v = Some Integer" by fastforce
      hence exei: "i. v = Intg i" by fastforce
      then obtain i where v: "v = Intg i" by blast
      thus ?thesis
      proof (cases "0 <=s i")
        case True
        thus ?thesis using True v = Intg i WTrtNewArray.prems
          by(cases "allocate h (Array_type T (nat (sint i))) = {}")(auto simp del: split_paired_Ex intro: RedNewArrayFail RedNewArray)
      next
        assume "¬ 0 <=s i"
        hence "i <s 0" by simp
        then have "extTA,P,t  newA TVal(Intg i),(h, l) -ε THROW NegativeArraySize,(h, l)"
          by - (rule RedNewArrayNegative, auto)
        with e v show ?thesis by blast
      qed
    next
      fix exa
      assume e: "e = Throw exa"
      then have "extTA,P,t  newA TThrow exa,(h, l) -ε Throw exa,(h, l)"
        by - (rule NewArrayThrow)
      with e show ?thesis by blast
    qed
  next
    assume "¬ final e"
    with IH De have exes: "e' s' ta. extTA,P,t  e,(h, l) -ta e',s'" by simp
    then obtain e' s' ta where "extTA,P,t  e,(h, l) -ta e',s'" by blast
    hence "extTA,P,t  newA Te,(h, l) -ta newA Te',s'" by - (rule NewArrayRed)
    thus ?thesis by blast
  qed
next
  case (WTrtCast E e T U l)
  have wte: "P,E,h  e : T"
   and IH: "l. 𝒟 e dom l; ¬ final e
                 e' s' tas. extTA,P,t  e,(h,l) -tas e',s'"
   and D: "𝒟 (Cast U e) dom l" by fact+
  from D have De: "𝒟 e dom l" by auto
  show ?case
  proof (cases "final e")
    assume "final e"
    thus ?thesis
    proof (rule finalE)
      fix v
      assume ev: "e = Val v"
      with WTrtCast obtain V where thvU: "typeofh v = V" by fastforce
      thus ?thesis
      proof (cases "P  V  U")
        assume "P  V  U"
        with thvU have "extTA,P,t  Cast U (Val v),(h, l) -ε Val v,(h,l)"
          by - (rule RedCast, auto)
        with ev show ?thesis by blast
      next
        assume "¬ P  V  U"
        with thvU have "extTA,P,t  Cast U (Val v),(h, l) -ε THROW ClassCast,(h,l)"
          by - (rule RedCastFail, auto)
        with ev show ?thesis by blast
      qed
    next
      fix a
      assume "e = Throw a"
      thus ?thesis by(blast intro!:CastThrow)
    qed
  next
    assume nf: "¬ final e"
    from IH[OF De nf] show ?thesis by (blast intro:CastRed)
  qed
next
  case (WTrtInstanceOf E e T U l)
  have wte: "P,E,h  e : T"
   and IH: "l. 𝒟 e dom l; ¬ final e
                 e' s' tas. extTA,P,t  e,(h,l) -tas e',s'"
   and D: "𝒟 (e instanceof U) dom l" by fact+
  from D have De: "𝒟 e dom l" by auto
  show ?case
  proof (cases "final e")
    assume "final e"
    thus ?thesis
    proof (rule finalE)
      fix v
      assume ev: "e = Val v"
      with WTrtInstanceOf obtain V where thvU: "typeofh v = V" by fastforce
      hence "extTA,P,t  (Val v) instanceof U,(h, l) -ε Val (Bool (v  Null  P  V  U)),(h,l)"
        by -(rule RedInstanceOf, auto)
      with ev show ?thesis by blast
    next
      fix a
      assume "e = Throw a"
      thus ?thesis by(blast intro!:InstanceOfThrow)
    qed
  next
    assume nf: "¬ final e"
    from IH[OF De nf] show ?thesis by (blast intro:InstanceOfRed)
  qed
next
  case WTrtVal thus ?case by(simp add:final_iff)
next
  case WTrtVar thus ?case by(fastforce intro:RedVar simp:hyper_isin_def)
next
  case (WTrtBinOp E e1 T1 e2 T2 bop T)
  show ?case
  proof cases
    assume "final e1"
    thus ?thesis
    proof (rule finalE)
      fix v1 assume [simp]: "e1 = Val v1"
      show ?thesis
      proof cases
        assume "final e2"
        thus ?thesis
        proof (rule finalE)
          fix v2 assume [simp]: "e2 = Val v2"
          with WTrtBinOp have type: "typeofh v1 = T1" "typeofh v2 = T2" by auto
          from binop_progress[OF this P  T1«bop»T2 : T] obtain va
            where "binop bop v1 v2 = va" by blast
          thus ?thesis by(cases va)(fastforce intro: RedBinOp RedBinOpFail)+
        next
          fix a assume "e2 = Throw a"
          thus ?thesis by(fastforce intro:BinOpThrow2)
        qed
      next
        assume "¬ final e2" with WTrtBinOp show ?thesis
          by simp (fast intro!:BinOpRed2)
      qed
    next
      fix a assume "e1 = Throw a"
      thus ?thesis by simp (fast intro:BinOpThrow1)
    qed
  next
    assume "¬ final e1" with WTrtBinOp show ?thesis
      by simp (fast intro:BinOpRed1)
  qed
next
  case (WTrtLAss E V T e T')
  show ?case
  proof cases
    assume "final e" with WTrtLAss show ?thesis
      by(fastforce simp:final_iff intro!:RedLAss LAssThrow)
  next
    assume "¬ final e" with WTrtLAss show ?thesis
      by simp (fast intro:LAssRed)
  qed
next
  case (WTrtAAcc E a T i l)
  have wte: "P,E,h  a : T⌊⌉"
   and wtei: "P,E,h  i : Integer"
   and IHa: "l. 𝒟 a dom l; ¬ final a
                  e' s' tas. extTA,P,t  a,(h,l) -tas e',s'"
   and IHi: "l. 𝒟 i dom l; ¬ final i
                  e' s' tas. extTA,P,t  i,(h,l) -tas e',s'"
   and D: "𝒟 (ai) dom l" by fact+
  have ref: "is_refT (T⌊⌉)" by simp
  from D have Da: "𝒟 a dom l" by simp
  show ?case
  proof (cases "final a")
    assume "final a"
    with wte ref show ?case
    proof (cases rule: finalRefE)
      case null
      thus ?thesis
      proof (cases "final i")
        assume "final i"
        thus ?thesis
        proof (rule finalE)
          fix v
          assume i: "i = Val v"
          have "extTA,P,t  nullVal v, (h, l) -ε THROW NullPointer, (h,l)"
            by(rule RedAAccNull)
          with i null show ?thesis by blast
        next
          fix ex
          assume i: "i = Throw ex"
          have "extTA,P,t  nullThrow ex, (h, l) -ε Throw ex, (h,l)"
            by(rule AAccThrow2)
          with i null show ?thesis by blast
        qed
      next
        assume "¬ final i"
        from WTrtAAcc null show ?thesis
          by simp
      qed
    next
      case (Array ad U)
      with wte obtain n where ty: "typeof_addr h ad = Array_type U n" by auto
      thus ?thesis
      proof (cases "final i")
        assume "final i"
        thus ?thesis
        proof(rule finalE)
          fix v
          assume [simp]: "i = Val v"
          with wtei have "typeofh v = Some Integer" by fastforce
          hence "i. v = Intg i" by fastforce
          then obtain i where [simp]: "v = Intg i" by blast
          thus ?thesis
          proof (cases "i <s 0  sint i  int n")
            case True
            with WTrtAAcc Array ty show ?thesis by (fastforce intro: RedAAccBounds)
          next
            case False
            then have "nat (sint i) < n"
              by (simp add: not_le word_sless_alt nat_less_iff)
            with ty have "P,h  ad@ACell (nat (sint i)) : U" by(auto intro!: addr_loc_type.intros)
            from heap_read_total[OF hconf this]
            obtain v where "heap_read h ad (ACell (nat (sint i))) v" by blast
            with False Array ty show ?thesis by(fastforce intro: RedAAcc)
          qed
        next
          fix ex
          assume "i = Throw ex"
          with WTrtAAcc Array show ?thesis by (fastforce intro: AAccThrow2)
        qed
      next
        assume "¬ final i"
        with WTrtAAcc Array show ?thesis by (fastforce intro: AAccRed2)
      qed
    next
      fix ex
      assume "a = Throw ex"
      with WTrtAAcc show ?thesis by (fastforce intro: AAccThrow1)
    qed simp
  next
    assume "¬ final a"
    with WTrtAAcc show ?thesis by (fastforce intro: AAccRed1)
  qed
next
  case (WTrtAAccNT E a i T l)
  have wte: "P,E,h  a : NT"
   and wtei: "P,E,h  i : Integer"
   and IHa: "l. 𝒟 a dom l; ¬ final a
                  e' s' tas. extTA,P,t  a,(h,l) -tas e',s'"
   and IHi: "l. 𝒟 i dom l; ¬ final i
                  e' s' tas. extTA,P,t  i,(h,l) -tas e',s'" by fact+
  have ref: "is_refT NT" by simp
  with WTrtAAccNT have Da: "𝒟 a dom l" by simp
  thus ?case
  proof (cases "final a")
    case True
    with wte ref show ?thesis
    proof (cases rule: finalRefE)
      case null
      thus ?thesis
      proof (cases "final i")
        assume "final i"
        thus ?thesis
        proof (rule finalE)
          fix v
          assume i: "i = Val v"
          have "extTA,P,t  nullVal v, (h, l) -ε THROW NullPointer, (h,l)"
            by (rule RedAAccNull)
          with WTrtAAccNT ‹final a null ‹final i i show ?thesis by blast
        next
          fix ex
          assume i: "i = Throw ex"
          have "extTA,P,t  nullThrow ex, (h, l) -ε Throw ex, (h,l)"
            by(rule AAccThrow2)
          with WTrtAAccNT ‹final a null ‹final i i show ?thesis by blast
        qed
      next
        assume "¬ final i"
        with WTrtAAccNT null show ?thesis
          by(fastforce intro: AAccRed2)
      qed
    next
      case Throw thus ?thesis by (fastforce intro: AAccThrow1)
    qed simp_all
  next
    case False
    with WTrtAAccNT Da show ?thesis by (fastforce intro:AAccRed1)
  qed
next
  case (WTrtAAss E a T i e T' l)
  have wta: "P,E,h  a : T⌊⌉"
    and wti: "P,E,h  i : Integer"
    and wte: "P,E,h  e : T'"
    and D: "𝒟 (ai := e) dom l"
    and IH1: "l. 𝒟 a dom l; ¬ final a  e' s' tas. extTA,P,t  a,(h, l) -tas e',s'"
    and IH2: "l. 𝒟 i dom l; ¬ final i  e' s' tas. extTA,P,t  i,(h, l) -tas e',s'"
    and IH3: "l. 𝒟 e dom l; ¬ final e  e' s' tas. extTA,P,t  e,(h, l) -tas e',s'" by fact+
  have ref: "is_refT (T⌊⌉)" by simp
  show ?case
  proof (cases "final a")
    assume fa: "final a"
    with wta ref show ?thesis
    proof(cases rule: finalRefE)
      case null
      show ?thesis
      proof(cases "final i")
        assume "final i"
        thus ?thesis
        proof (rule finalE)
          fix v
          assume i: "i = Val v"
          with wti have "typeofh v = Some Integer" by fastforce
          then obtain idx where "v = Intg idx" by fastforce
          thus ?thesis
          proof (cases "final e")
            assume "final e"
            thus ?thesis
            proof (rule finalE)
              fix w
              assume "e = Val w"
              with WTrtAAss null show ?thesis by (fastforce intro: RedAAssNull)
            next
              fix ex
              assume "e = Throw ex"
              with WTrtAAss null show ?thesis by (fastforce intro: AAssThrow3)
            qed
          next
            assume "¬ final e"
            with WTrtAAss null show ?thesis by (fastforce intro: AAssRed3)
          qed
        next
          fix ex
          assume "i = Throw ex"
          with WTrtAAss null show ?thesis by (fastforce intro: AAssThrow2)
        qed
      next
        assume "¬ final i"
        with WTrtAAss null show ?thesis by (fastforce intro: AAssRed2)
      qed
    next
      case (Array ad U)
      with wta obtain n where ty: "typeof_addr h ad = Array_type U n" by auto
      thus ?thesis
      proof (cases "final i")
        assume fi: "final i"
        thus ?thesis
        proof (rule finalE)
          fix v
          assume ivalv: "i = Val v"
          with wti have "typeofh v = Some Integer" by fastforce
          then obtain idx where vidx: "v = Intg idx" by fastforce
          thus ?thesis
          proof (cases "final e")
            assume fe: "final e"
            thus ?thesis
            proof(rule finalE)
              fix w
              assume evalw: "e = Val w"
              show ?thesis
              proof(cases "idx <s 0  sint idx  int n")
                case True
                with ty evalw Array ivalv vidx show ?thesis by(fastforce intro: RedAAssBounds)
              next
                case False
                then have "nat (sint idx) < n"
                  by (simp add: not_le word_sless_alt nat_less_iff)
                with ty have adal: "P,h  ad@ACell (nat (sint idx)) : U"
                  by(auto intro!: addr_loc_type.intros)
                show ?thesis
                proof(cases "P  T'  U")
                  case True
                  with wte evalw have "P,h  w :≤ U"
                    by(auto simp add: conf_def)
                  from heap_write_total[OF hconf adal this]
                  obtain h' where h': "heap_write h ad (ACell (nat (sint idx))) w h'" ..
                  with ty False vidx ivalv evalw Array wte True
                  show ?thesis by(fastforce intro: RedAAss)
                next
                  case False
                  with ty vidx ivalv evalw Array wte ¬ (idx <s 0  sint idx  int n)
                  show ?thesis by(fastforce intro: RedAAssStore)
                qed
              qed
            next
              fix ex
              assume "e = Throw ex"
              with Array ivalv show ?thesis by (fastforce intro: AAssThrow3)
            qed
          next
            assume "¬ final e"
            with WTrtAAss Array fi ivalv vidx show ?thesis by (fastforce intro: AAssRed3)
          qed
        next
          fix ex
          assume "i = Throw ex"
          with WTrtAAss Array show ?thesis by (fastforce intro: AAssThrow2)
        qed
      next
        assume "¬ final i"
        with WTrtAAss Array show ?thesis by (fastforce intro: AAssRed2)
      qed
    next
      fix ex
      assume "a = Throw ex"
      with WTrtAAss show ?thesis by (fastforce intro:AAssThrow1)
    qed simp_all
  next
    assume "¬ final a"
    with WTrtAAss show ?thesis by (fastforce intro: AAssRed1)
  qed
next
  case (WTrtAAssNT E a i e T' l)
  have wta: "P,E,h  a : NT"
    and wti: "P,E,h  i : Integer"
    and wte: "P,E,h  e : T'"
    and D: "𝒟 (ai := e) dom l"
    and IH1: "l. 𝒟 a dom l; ¬ final a  e' s' tas. extTA,P,t  a,(h, l) -tas e',s'"
    and IH2: "l. 𝒟 i dom l; ¬ final i  e' s' tas. extTA,P,t  i,(h, l) -tas e',s'"
    and IH3: "l. 𝒟 e dom l; ¬ final e  e' s' tas. extTA,P,t  e,(h, l) -tas e',s'" by fact+
  have ref: "is_refT NT" by simp
  show ?case
  proof (cases "final a")
    assume fa: "final a"
    show ?case
    proof (cases "final i")
      assume fi: "final i"
      show ?case
      proof (cases "final e")
        assume fe: "final e"
        with WTrtAAssNT fa fi show ?thesis
          by (fastforce simp:final_iff intro: RedAAssNull AAssThrow1 AAssThrow2 AAssThrow3)
      next
        assume "¬ final e"
        with WTrtAAssNT fa fi show ?thesis
          by (fastforce simp: final_iff intro!:AAssRed3 AAssThrow1 AAssThrow2)
      qed
    next
      assume "¬ final i"
      with WTrtAAssNT fa show ?thesis
        by (fastforce simp: final_iff intro!:AAssRed2 AAssThrow1)
    qed
  next
    assume "¬ final a"
    with WTrtAAssNT show ?thesis by (fastforce simp: final_iff intro!:AAssRed1)
  qed
next
  case (WTrtALength E a T l)
  show ?case
  proof(cases "final a")
    case True
    note wta = P,E,h  a : T⌊⌉
    thus ?thesis 
    proof(rule finalRefE[OF _ _ True])
      show "is_refT (T⌊⌉)" by simp
    next
      assume "a = null"
      thus ?thesis by(fastforce intro: RedALengthNull)
    next
      fix ad U
      assume "a = addr ad" and "T⌊⌉ = U⌊⌉"
      with wta show ?thesis by(fastforce intro: RedALength)
    next
      fix ad
      assume "a = Throw ad"
      thus ?thesis by (fastforce intro: ALengthThrow)
    qed simp
  next
    case False
    from ‹𝒟 (a∙length) dom l have "𝒟 a dom l" by simp
    with False 𝒟 a dom l; ¬ final a  e' s' ta. extTA,P,t  a,(h, l) -ta e',s'
    obtain e' s' ta where "extTA,P,t  a,(h, l) -ta e',s'" by blast
    thus ?thesis by(blast intro: ALengthRed)
  qed
next
  case (WTrtALengthNT E a T l)
  show ?case
  proof(cases "final a")
    case True
    note wta = P,E,h  a : NT›
    thus ?thesis
    proof(rule finalRefE[OF _ _ True])
      show "is_refT NT" by simp
    next
      assume "a = null"
      thus ?thesis by(blast intro: RedALengthNull)
    next
      fix ad
      assume "a = Throw ad"
      thus ?thesis by(blast intro: ALengthThrow)
    qed simp_all
  next
    case False
    from ‹𝒟 (a∙length) dom l have "𝒟 a dom l" by simp
    with False 𝒟 a dom l; ¬ final a  e' s' ta. extTA,P,t  a,(h, l) -ta e',s'
    obtain e' s' ta where "extTA,P,t  a,(h, l) -ta e',s'" by blast
    thus ?thesis by(blast intro: ALengthRed)
  qed
next
  case (WTrtFAcc E e U C F T fm D l)
  have wte: "P,E,h  e : U"
    and icto: "class_type_of' U = C"
   and field: "P  C has F:T (fm) in D" by fact+
  show ?case
  proof cases
    assume "final e"
    with wte icto show ?thesis
    proof (cases rule: final_addrE)
      case (addr a)
      with wte obtain hU where ty: "typeof_addr h a = hU" "U = ty_of_htype hU" by auto
      with icto field have "P,h  a@CField D F : T" by(auto intro: addr_loc_type.intros)
      from heap_read_total[OF hconf this]
      obtain v where "heap_read h a (CField D F) v" by blast
      with addr ty show ?thesis by(fastforce intro: RedFAcc)
    next
      fix a assume "e = Throw a"
      thus ?thesis by(fastforce intro:FAccThrow)
    qed
  next
    assume "¬ final e" with WTrtFAcc show ?thesis
      by(fastforce intro!:FAccRed)
  qed
next
  case (WTrtFAccNT E e F D T l)
  show ?case
  proof cases
    assume "final e"  ― ‹@{term e} is @{term null} or @{term throw}
    with WTrtFAccNT show ?thesis
      by(fastforce simp:final_iff intro: RedFAccNull FAccThrow)
  next
    assume "¬ final e" ― ‹@{term e} reduces by IH›
    with WTrtFAccNT show ?thesis by simp (fast intro:FAccRed)
  qed
next
  case (WTrtFAss E e1 U C F T fm D e2 T2 l)
  have wte1: "P,E,h  e1 : U"
    and icto: "class_type_of' U = C"
    and field: "P  C has F:T (fm) in D" by fact+
  show ?case
  proof cases
    assume "final e1"
    with wte1 icto show ?thesis
    proof (rule final_addrE)
      fix a assume e1: "e1 = addr a"
      show ?thesis
      proof cases
        assume "final e2"
        thus ?thesis
        proof (rule finalE)
          fix v assume e2: "e2 = Val v"
          from wte1 field icto e1 have adal: "P,h  a@CField D F : T"
            by(auto intro: addr_loc_type.intros)
          from e2 P  T2  T P,E,h  e2 : T2
          have "P,h  v :≤ T" by(auto simp add: conf_def)
          from heap_write_total[OF hconf adal this] obtain h' 
            where "heap_write h a (CField D F) v h'" ..
          with wte1 field e1 e2 show ?thesis
            by(fastforce intro: RedFAss)
        next
          fix a assume "e2 = Throw a"
          thus ?thesis using e1 by(fastforce intro:FAssThrow2)
        qed
      next
        assume "¬ final e2" with WTrtFAss ‹final e1 e1 show ?thesis
          by simp (fast intro!:FAssRed2)
      qed
    next
      fix a assume "e1 = Throw a"
      thus ?thesis by(fastforce intro:FAssThrow1)
    qed
  next
    assume "¬ final e1" with WTrtFAss show ?thesis
      by(simp del: split_paired_Ex)(blast intro!:FAssRed1)
  qed
next
  case (WTrtFAssNT E e1 e2 T2 F D l)
  show ?case
  proof cases
    assume "final e1"  ― ‹@{term e1} is @{term null} or @{term throw}
    show ?thesis
    proof cases
      assume "final e2"  ― ‹@{term e2} is @{term Val} or @{term throw}
      with WTrtFAssNT ‹final e1 show ?thesis
        by(fastforce simp:final_iff intro: RedFAssNull FAssThrow1 FAssThrow2)
    next
      assume "¬ final e2" ― ‹@{term e2} reduces by IH›
      with WTrtFAssNT ‹final e1 show ?thesis
        by (fastforce  simp:final_iff intro!:FAssRed2 FAssThrow1)
    qed
  next
    assume "¬ final e1" ― ‹@{term e1} reduces by IH›
    with WTrtFAssNT show ?thesis by (fastforce intro:FAssRed1)
  qed
next
  case (WTrtCAS E e1 U C F T fm D e2 T2 e3 T3)
  show ?case
  proof(cases "final e1")
    case e1: True
    with WTrtCAS.hyps(1,3) show ?thesis
    proof(rule final_addrE)
      fix a
      assume e1: "e1 = addr a"
      with WTrtCAS.hyps(1) obtain hU
        where ty: "typeof_addr h a = hU" "U = ty_of_htype hU" by auto
      with WTrtCAS.hyps(3,4) have adal: "P,h  a@CField D F : T" by(auto intro: addr_loc_type.intros)
      from heap_read_total[OF hconf this]
      obtain v where v: "heap_read h a (CField D F) v" by blast
      show ?thesis
      proof(cases "final e2")
        case e2: True
        show ?thesis
        proof(cases "final e3")
          case e3: True
          consider (Val2) v2 where "e2 = Val v2" | (Throw2) a2 where "e2 = Throw a2"
            using e2 by(auto simp add: final_iff)
          then show ?thesis
          proof(cases)
            case Val2
            consider (Succeed) v3 where "e3 = Val v3" "v2 = v" 
              | (Fail) v3 where "e3 = Val v3" "v2  v" 
              | (Throw3) a3 where "e3 = Throw a3"
              using e3 by(auto simp add: final_iff)
            then show ?thesis
            proof cases
              case Succeed
              with WTrtCAS.hyps(9,11) adal have "P,h  v3 :≤ T" by(auto simp add: conf_def)
              from heap_write_total[OF hconf adal this] obtain h' 
                where "heap_write h a (CField D F) v3 h'" ..
              with Val2 e1 v Succeed show ?thesis
                by(auto intro: RedCASSucceed simp del: split_paired_Ex)
            next
              case Fail
              with Val2 e1 v show ?thesis 
                by(auto intro: RedCASFail simp del: split_paired_Ex)
            next
              case Throw3
              then show ?thesis using e1 Val2 by(auto intro: CASThrow3 simp del: split_paired_Ex)
            qed
          next
            case Throw2
            then show ?thesis using e1 by(auto intro: CASThrow2 simp del: split_paired_Ex)
          qed
        next
          case False
          with WTrtCAS e1 e2 show ?thesis 
            by(fastforce simp del: split_paired_Ex simp add: final_iff intro: CASRed3 CASThrow2)
        qed
      next
        case False
        with WTrtCAS e1 show ?thesis 
          by(fastforce intro: CASRed2 CASThrow2 simp del: split_paired_Ex)
      qed
    qed(fastforce intro: CASThrow)
  next
    case False
    then show ?thesis using WTrtCAS by(fastforce intro: CASRed1)
  qed
next
  case (WTrtCASNT E e1 e2 T2 e3 T3 D F)
  note [simp del] = split_paired_Ex
  show ?case
  proof(cases "final e1")
    case e1: True
    show ?thesis
    proof(cases "final e2")
      case e2: True
      show ?thesis
      proof(cases "final e3")
        case True
        with e1 e2 WTrtCASNT show ?thesis
          by(fastforce simp add: final_iff intro: CASNull CASThrow CASThrow2 CASThrow3) 
      next
        case False
        with e1 e2 WTrtCASNT show ?thesis
          by(fastforce simp add: final_iff intro: CASRed3 CASThrow CASThrow2) 
      qed
    next
      case False
      with e1 WTrtCASNT show ?thesis
        by(fastforce simp add: final_iff intro: CASRed2 CASThrow) 
    qed
  next
    case False
    with WTrtCASNT show ?thesis
      by(fastforce simp add: final_iff intro: CASRed1) 
  qed
next
  case (WTrtCall E e U C M Ts T meth D es Ts' l)
  have wte: "P,E,h  e : U" 
    and icto: "class_type_of' U = C" by fact+
  have IHe: "l.  𝒟 e dom l; ¬ final e 
              e' s' tas. extTA,P,t  e,(h, l) -tas e',s'" by fact
  have sees: "P  C sees M: TsT = meth in D" by fact
  have wtes: "P,E,h  es [:] Ts'" by fact
  have IHes: "l. 𝒟s es dom l; ¬ finals es  es' s' ta. extTA,P,t  es,(h, l) [-ta→] es',s'" by fact
  have subtype: "P  Ts' [≤] Ts" by fact
  have dae: "𝒟 (eM(es)) dom l" by fact
  show ?case
  proof(cases "final e")
    assume fine: "final e"
    with wte icto show ?thesis
    proof (rule final_addrE)
      fix a assume e_addr: "e = addr a"
      show ?thesis
      proof(cases "vs. es = map Val vs")
        assume es: "vs. es = map Val vs"
        from wte e_addr obtain hU where ha: "typeof_addr h a = hU" "U = ty_of_htype hU"  by(auto)
        have "length es = length Ts'" using wtes by(auto simp add: WTrts_conv_list_all2 dest: list_all2_lengthD)
        moreover from subtype have "length Ts' = length Ts" by(auto dest: list_all2_lengthD)
        ultimately have esTs: "length es = length Ts" by(auto)
        show ?thesis
        proof(cases meth)
          case (Some pnsbody)
          with esTs e_addr ha sees subtype es sees_wf_mdecl[OF wf sees] icto
          show ?thesis by(cases pnsbody) (fastforce intro!: RedCall simp:list_all2_iff wf_mdecl_def)
        next
          case None
          with sees wf have "DM(Ts) :: T" by(auto intro: sees_wf_native)
          moreover from es obtain vs where vs: "es = map Val vs" ..
          with wtes have tyes: "map typeofh vs = map Some Ts'" by simp
          with ha DM(Ts) :: T icto sees None
          have "P,h  aM(vs) : T" using subtype by(auto simp add: external_WT'_iff)
          from external_call_progress[OF wf this hconf, of t] obtain ta va h'
            where "P,t  aM(vs), h -ta→ext va, h'" by blast
          thus ?thesis using ha icto None sees vs e_addr
            by(fastforce intro: RedCallExternal simp del: split_paired_Ex)
        qed
      next
        assume "¬(vs. es = map Val vs)"
        hence not_all_Val: "¬(e  set es. v. e = Val v)"
          by(simp add:ex_map_conv)
        let ?ves = "takeWhile (λe. v. e = Val v) es"
        let ?rest = "dropWhile (λe. v. e = Val v) es"
        let ?ex = "hd ?rest" let ?rst = "tl ?rest"
        from not_all_Val have nonempty: "?rest  []" by auto
        hence es: "es = ?ves @ ?ex # ?rst" by simp
        have "e  set ?ves. v. e = Val v" by(fastforce dest:set_takeWhileD)
        then obtain vs where ves: "?ves = map Val vs"
          using ex_map_conv by blast
        show ?thesis
        proof cases
          assume "final ?ex"
          moreover from nonempty have "¬(v. ?ex = Val v)"
            by(auto simp:neq_Nil_conv simp del:dropWhile_eq_Nil_conv)
              (simp add:dropWhile_eq_Cons_conv)
          ultimately obtain b where ex_Throw: "?ex = Throw b"
            by(fast elim!:finalE)
          show ?thesis using e_addr es ex_Throw ves
            by(fastforce intro:CallThrowParams)
        next
          assume not_fin: "¬ final ?ex"
          have "finals es = finals(?ves @ ?ex # ?rst)" using es
            by(rule arg_cong)
          also have " = finals(?ex # ?rst)" using ves by simp
          finally have "finals es = finals(?ex # ?rst)" .
          hence "¬ finals es" using not_finals_ConsI[OF not_fin] by blast
          thus ?thesis using e_addr dae IHes  by(fastforce intro!:CallParams)
        qed
      qed
    next
      fix a assume "e = Throw a"
      thus ?thesis by(fast intro!:CallThrowObj)
    qed
  next
    assume "¬ final e"
    with WTrtCall show ?thesis by(simp del: split_paired_Ex)(blast intro!:CallObj)
  qed
next
  case (WTrtCallNT E e es Ts M T l)
  have wte: "P,E,h  e : NT" by fact
  have IHe: "l.  𝒟 e dom l; ¬ final e 
              e' s' tas. extTA,P,t  e,(h, l) -tas e',s'"  by fact
  have IHes: "l. 𝒟s es dom l; ¬ finals es  es' s' ta. extTA,P,t  es,(h, l) [-ta→] es',s'" by fact
  have wtes: "P,E,h  es [:] Ts" by fact
  have dae: "𝒟 (eM(es)) dom l" by fact
  show ?case
  proof(cases "final e")
    assume "final e"
    moreover
    { fix v assume "e = Val v"
      hence "e = null" using WTrtCallNT by simp
      have ?case
      proof cases
        assume "finals es"
        moreover
        { fix vs assume "es = map Val vs"
          with WTrtCallNT e = null› ‹finals es have ?thesis by(fastforce intro: RedCallNull) }
        moreover
        { fix vs a es' assume "es = map Val vs @ Throw a # es'"
          with WTrtCallNT e = null› ‹finals es have ?thesis by(fastforce intro: CallThrowParams) }
        ultimately show ?thesis by(fastforce simp:finals_iff)
      next
        assume "¬ finals es" ― ‹@{term es} reduces by IH›
        with WTrtCallNT e = null› show ?thesis by(fastforce intro: CallParams)
      qed
    }
    moreover
    { fix a assume "e = Throw a"
      with WTrtCallNT have ?case by(fastforce intro: CallThrowObj) }
    ultimately show ?thesis by(fastforce simp:final_iff)
  next
    assume "¬ final e" ― ‹@{term e} reduces by IH›
    with WTrtCallNT show ?thesis by (fastforce intro:CallObj)
  qed
next
  case (WTrtBlock E V T e T' vo l)
  have IH: "l. 𝒟 e dom l; ¬ final e
                  e' s' tas. extTA,P,t  e,(h,l) -tas e',s'"
   and D: "𝒟 {V:T=vo; e} dom l" by fact+
  show ?case
  proof cases
    assume "final e"
    thus ?thesis
    proof (rule finalE)
      fix v assume "e = Val v" thus ?thesis by(fast intro:RedBlock)
    next
      fix a assume "e = Throw a"
      thus ?thesis by(fast intro:BlockThrow)
    qed
  next
    assume not_fin: "¬ final e"
    from D have De: "𝒟 e dom(l(V:=vo))" by(auto simp add:hyperset_defs)
    from IH[OF De not_fin]
    obtain h' l' e' tas where red: "extTA,P,t  e,(h,l(V:=vo)) -tas e',(h',l')"
      by auto
    thus ?thesis by(blast intro: BlockRed)
  qed
next
  case (WTrtSynchronized E o' T e T' l)
  note wto = P,E,h  o' : T
  note IHe = l. 𝒟 e dom l; ¬ final e   e' s' tas. extTA,P,t  e,(h, l) -tas e',s'
  note wte = P,E,h  e : T'
  note IHo = l. 𝒟 o' dom l; ¬ final o'   e' s' tas. extTA,P,t  o',(h, l) -tas e',s'
  note refT = ‹is_refT T
  note dae = ‹𝒟 (sync(o') e) dom l
  show ?case
  proof(cases "final o'")
    assume fino: "final o'" 
    thus ?thesis
    proof (rule finalE)
      fix v
      assume oval: "o' = Val v"
      with wto refT show ?thesis
      proof(cases "v")
        assume vnull: "v = Null"
        with oval vnull show ?thesis
          by(fastforce intro: SynchronizedNull)
      next
        fix ad
        assume vaddr: "v = Addr ad"
        thus ?thesis using oval 
          by(fastforce intro: LockSynchronized)
      qed(auto elim: refTE)
    next
      fix a
      assume othrow: "o' = Throw a"
      thus ?thesis by(fastforce intro: SynchronizedThrow1)
    qed
  next
    assume nfino: "¬ final o'"
    with dae IHo show ?case by(fastforce intro: SynchronizedRed1)
  qed
next
  case (WTrtInSynchronized E a T e T' l)
  show ?case
  proof(cases "final e")
    case True thus ?thesis
      by(fastforce elim!: finalE intro: UnlockSynchronized SynchronizedThrow2)
  next
    case False 
    moreover from ‹𝒟 (insync(a) e) dom l have "𝒟 e dom l" by simp
    moreover note IHe = l. 𝒟 e dom l; ¬ final e  e' s' tas. extTA,P,t  e,(h, l) -tas e',s'
    ultimately show ?thesis by(fastforce intro: SynchronizedRed2)
  qed
next
  case (WTrtSeq E e1 T1 e2 T2 l)
  show ?case
  proof cases
    assume "final e1"
    thus ?thesis
      by(fast elim:finalE intro:intro:RedSeq SeqThrow)
  next
    assume "¬ final e1" with WTrtSeq show ?thesis
      by(simp del: split_paired_Ex)(blast intro!:SeqRed)
  qed
next
  case (WTrtCond E e e1 T1 e2 T2 T l)
  have wt: "P,E,h  e : Boolean" by fact
  show ?case
  proof cases
    assume "final e"
    thus ?thesis
    proof (rule finalE)
      fix v assume val: "e = Val v"
      then obtain b where v: "v = Bool b" using wt by auto
      show ?thesis
      proof (cases b)
        case True with val v show ?thesis by(fastforce intro:RedCondT)
      next
        case False with val v show ?thesis by(fastforce intro:RedCondF)
      qed
    next
      fix a assume "e = Throw a"
      thus ?thesis by(fast intro:CondThrow)
    qed
  next
    assume "¬ final e" with WTrtCond show ?thesis
      by simp (fast intro:CondRed)
  qed
next
  case WTrtWhile show ?case by(fast intro:RedWhile)
next
  case (WTrtThrow E e T T' l)
  show ?case
  proof cases
    assume "final e" ― ‹Then @{term e} must be @{term throw} or @{term null}
    thus ?thesis
    proof(induct rule: finalE)
      case (Val v)
      with P  T  Class Throwable› ¬ final (throw e) P,E,h  e : T
      have "v = Null" by(cases v)(auto simp add: final_iff widen_Class)
      thus ?thesis using Val by(fastforce intro: RedThrowNull)
    next
      case (Throw a)
      thus ?thesis by(fastforce intro: ThrowThrow)
    qed
  next
    assume "¬ final e" ― ‹Then @{term e} must reduce›
    with WTrtThrow show ?thesis by simp (blast intro:ThrowRed)
  qed
next
  case (WTrtTry E e1 T1 V C e2 T2 l)
  have wt1: "P,E,h  e1 : T1" by fact
  show ?case
  proof cases
    assume "final e1"
    thus ?thesis
    proof (rule finalE)
      fix v assume "e1 = Val v"
      thus ?thesis by(fast intro:RedTry)
    next
      fix a
      assume e1_Throw: "e1 = Throw a"
      with wt1 obtain D where ha: "typeof_addr h a = Class_type D"
        by(auto simp add: widen_Class)
      thus ?thesis using e1_Throw
        by(cases "P  D * C")(fastforce intro:RedTryCatch RedTryFail)+
    qed
  next
    assume "¬ final e1"
    with WTrtTry show ?thesis by simp (fast intro:TryRed)
  qed
next
  case WTrtNil thus ?case by simp
next
  case (WTrtCons E e T es Ts)
  have IHe: "l. 𝒟 e dom l; ¬ final e
                 e' s' ta. extTA,P,t  e,(h,l) -ta e',s'"
   and IHes: "l. 𝒟s es dom l; ¬ finals es
              es' s' ta. extTA,P,t  es,(h,l) [-ta→] es',s'"
   and D: "𝒟s (e#es) dom l" and not_fins: "¬ finals(e # es)" by fact+
  have De: "𝒟 e dom l" and Des: "𝒟s es (dom l  𝒜 e)"
    using D by auto
  show ?case
  proof cases
    assume "final e"
    thus ?thesis
    proof (rule finalE)
      fix v assume e: "e = Val v"
      hence Des': "𝒟s es dom l" using De Des by auto
      have not_fins_tl: "¬ finals es" using not_fins e by simp
      show ?thesis using e IHes[OF Des' not_fins_tl]
        by (blast intro!:ListRed2)
    next
      fix a assume "e = Throw a"
      hence False using not_fins by simp
      thus ?thesis ..
    qed
  next
    assume "¬ final e"
    with IHe[OF De] show ?thesis by(fast intro!:ListRed1)
  qed
qed

end

Theory DefAssPreservation

(*  Title:      JinjaThreads/J/DefAssPreservation.thy
    Author:     Andreas Lochbihler, Tobias Nipkow
*)

section ‹Preservation of definite assignment›

theory DefAssPreservation
imports
  DefAss
  JWellForm
  SmallStep
begin

text‹Preservation of definite assignment more complex and requires a
few lemmas first.›

lemma D_extRetJ [intro!]: "𝒟 e A  𝒟 (extRet2J e va) A"
by(cases va) simp_all

lemma blocks_defass [iff]: "A.  length Vs = length Ts; length vs = length Ts 
 𝒟 (blocks Vs Ts vs e) A = 𝒟 e (A  set Vs)"
(*<*)
apply(induct Vs Ts vs e rule:blocks.induct)
apply(simp_all add:hyperset_defs)
done
(*>*)

context J_heap_base begin

lemma red_lA_incr: "extTA,P,t  e,s -ta e',s'  dom (lcl s)  𝒜 e   dom (lcl s')  𝒜 e'"
  and reds_lA_incr: "extTA,P,t  es,s [-ta→] es',s'  dom (lcl s)  𝒜s es   dom (lcl s')  𝒜s es'"
apply(induct rule:red_reds.inducts)
apply(simp_all del:fun_upd_apply add:hyperset_defs)
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply(force split: if_split_asm)
apply blast
apply blast
apply blast
apply blast
apply blast
apply(blast dest: red_lcl_incr)
apply(blast dest: red_lcl_incr)
by blast+

end

text‹Now preservation of definite assignment.›

declare hyperUn_comm [simp del]
declare hyperUn_leftComm [simp del]

context J_heap_base begin

lemma assumes wf: "wf_J_prog P"
  shows red_preserves_defass: "extTA,P,t  e,s -ta e',s'  𝒟 e dom (lcl s)  𝒟 e' dom (lcl s')"
  and reds_preserves_defass: "extTA,P,t  es,s [-ta→] es',s'  𝒟s es dom (lcl s)  𝒟s es' dom (lcl s')"
proof (induction rule:red_reds.inducts)
  case BinOpRed1 thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
  case AAccRed1 thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
  case AAssRed1 thus ?case by(auto intro: red_lA_incr sqUn_lem D_mono)
next
  case AAssRed2 thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
  case FAssRed1 thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
  case CASRed1 thus ?case by(auto intro: red_lA_incr sqUn_lem D_mono)
next
  case CASRed2 thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
  case CallObj thus ?case by (auto elim!: Ds_mono[OF red_lA_incr])
next
  case CallParams thus ?case by(auto elim!: Ds_mono[OF red_lA_incr])
next
  case RedCall thus ?case by(auto dest!:sees_wf_mdecl[OF wf] simp:wf_mdecl_def elim!:D_mono')
next
  case BlockRed thus ?case
    by(auto simp:hyperset_defs elim!:D_mono' simp del:fun_upd_apply split: if_split_asm)
next
  case SynchronizedRed1 thus ?case by(auto elim!: D_mono[OF red_lA_incr])
next
  case SeqRed thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
  case CondRed thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
  case TryRed thus ?case
    by (fastforce dest:red_lcl_incr intro:D_mono' simp:hyperset_defs)
next
  case RedWhile thus ?case by(auto simp:hyperset_defs elim!:D_mono')
next
  case ListRed1 thus ?case by (auto elim!: Ds_mono[OF red_lA_incr])
qed (auto simp:hyperset_defs)

end

end

Theory TypeSafe

(*  Title:      JinjaThreads/J/SmallTypeSafe.thy
    Author:     Tobias Nipkow, Andreas Lochbihler
*)

section ‹Type Safety Proof›

theory TypeSafe
imports
  Progress
  DefAssPreservation
begin

subsection‹Basic preservation lemmas›

text‹First two easy preservation lemmas.›

theorem (in J_conf_read)
  shows red_preserves_hconf:
  " extTA,P,t  e,s -ta e',s'; P,E,hp s  e : T; hconf (hp s)   hconf (hp s')"
  and reds_preserves_hconf:
  " extTA,P,t  es,s [-ta→] es',s'; P,E,hp s  es [:] Ts; hconf (hp s)   hconf (hp s')"
proof (induct arbitrary: T E and Ts E rule: red_reds.inducts)
  case RedNew thus ?case
    by(auto intro: hconf_heap_ops_mono)
next
  case RedNewFail thus ?case
    by(auto intro: hconf_heap_ops_mono)
next
  case RedNewArray thus ?case
    by(auto intro: hconf_heap_ops_mono)
next
  case RedNewArrayFail thus ?case
    by(auto intro: hconf_heap_ops_mono)
next
  case (RedAAss h a U n i v U' h' l)
  from ‹sint i < int n 0 <=s i
  have "nat (sint i) < n"
    by (simp add: word_sle_eq nat_less_iff)
  thus ?case using RedAAss
    by(fastforce elim: hconf_heap_write_mono intro: addr_loc_type.intros simp add: conf_def)
next
  case RedFAss thus ?case
    by(fastforce elim: hconf_heap_write_mono intro: addr_loc_type.intros simp add: conf_def)
next
  case RedCASSucceed thus ?case
    by(fastforce elim: hconf_heap_write_mono intro: addr_loc_type.intros simp add: conf_def)
next
  case (RedCallExternal s a U M Ts T' D vs ta va h' ta' e' s')
  hence "P,hp s  aM(vs) : T"
    by(fastforce simp add: external_WT'_iff dest: sees_method_fun)
  with RedCallExternal show ?case by(auto dest: external_call_hconf)
qed auto

theorem (in J_heap) red_preserves_lconf:
  " extTA,P,t  e,s -ta e',s'; P,E,hp s  e:T; P,hp s  lcl s (:≤) E   P,hp s'  lcl s' (:≤) E"
  and reds_preserves_lconf:
  " extTA,P,t  es,s [-ta→] es',s'; P,E,hp s  es[:]Ts; P,hp s  lcl s (:≤) E   P,hp s'  lcl s' (:≤) E"
proof(induct arbitrary: T E and Ts E rule:red_reds.inducts)
  case RedNew thus ?case
    by(fastforce intro:lconf_hext hext_heap_ops simp del: fun_upd_apply)
next
  case RedNewFail thus ?case
    by(auto intro:lconf_hext hext_heap_ops simp del: fun_upd_apply)
next
  case RedNewArray thus ?case
    by(fastforce intro:lconf_hext hext_heap_ops simp del: fun_upd_apply)
next
  case RedNewArrayFail thus ?case
    by(fastforce intro:lconf_hext hext_heap_ops simp del: fun_upd_apply)
next
  case RedLAss thus ?case 
    by(fastforce elim: lconf_upd simp add: conf_def simp del: fun_upd_apply )
next
  case RedAAss thus ?case
    by(fastforce intro:lconf_hext hext_heap_ops simp del: fun_upd_apply)
next
  case RedFAss thus ?case
    by(fastforce intro:lconf_hext hext_heap_ops simp del: fun_upd_apply)
next
  case RedCASSucceed thus ?case
    by(fastforce intro:lconf_hext hext_heap_ops simp del: fun_upd_apply)
next
  case (BlockRed e h x V vo ta e' h' x' T T' E)
  note red = extTA,P,t  e,(h, x(V := vo)) -ta e',(h', x')
  note IH = T E. P,E,hp (h, x(V := vo))  e : T;
               P,hp (h, x(V := vo))  lcl (h, x(V := vo)) (:≤) E
               P,hp (h', x')  lcl (h', x') (:≤) E
  note wt = P,E,hp (h, x)  {V:T=vo; e} : T'
  note lconf = P,hp (h, x)  lcl (h, x) (:≤) E
  from lconf_hext[OF lconf[simplified] red_hext_incr[OF red, simplified]]
  have "P,h'  x (:≤) E" .
  moreover from wt have "P,E(VT),h  e : T'" by(cases vo, auto)
  moreover from lconf wt have "P,h  x(V := vo) (:≤) E(V  T)"
    by(cases vo)(simp add: lconf_def,auto intro: lconf_upd2 simp add: conf_def)
  ultimately have "P,h'  x' (:≤) E(VT)" 
    by(auto intro: IH[simplified])
  with P,h'  x (:≤) E show ?case
    by(auto simp add: lconf_def split: if_split_asm)
next
  case (RedCallExternal s a U M Ts T' D vs ta va h' ta' e' s')
  from P,t  aM(vs),hp s -ta→ext va,h' have "hp s  h'" by(rule red_external_hext)
  with s' = (h', lcl s) P,hp s  lcl s (:≤) E show ?case by(auto intro: lconf_hext)
qed auto

text‹Combining conformance of heap and local variables:›

definition (in J_heap_conf_base) sconf :: "env  ('addr, 'heap) Jstate  bool" ("_  _ "   [51,51]50)
  where "E  s     let (h,l) = s in hconf h  P,h  l (:≤) E  preallocated h"

context J_conf_read begin

lemma red_preserves_sconf:
  " extTA,P,t  e,s -tas e',s'; P,E,hp s  e : T; E  s    E  s' "
apply(auto dest: red_preserves_hconf red_preserves_lconf simp add:sconf_def)
apply(fastforce dest: red_hext_incr intro: preallocated_hext)
done

lemma reds_preserves_sconf:
  " extTA,P,t  es,s [-ta→] es',s'; P,E,hp s  es [:] Ts; E  s    E  s' "
apply(auto dest: reds_preserves_hconf reds_preserves_lconf simp add: sconf_def)
apply(fastforce dest: reds_hext_incr intro: preallocated_hext)
done

end

lemma (in J_heap_base) wt_external_call:
  " conf_extRet P h va T; P,E,h  e : T   T'. P,E,h  extRet2J e va : T'  P  T'  T"
by(cases va)(auto simp add: conf_def)

subsection "Subject reduction"

theorem (in J_conf_read) assumes wf: "wf_J_prog P"
  shows subject_reduction:
  " extTA,P,t  e,s -ta e',s'; E  s ; P,E,hp s  e:T; P,hp s  t √t 
   T'. P,E,hp s'  e':T'  P  T'  T"
  and subjects_reduction:
  " extTA,P,t  es,s [-ta→] es',s'; E  s ; P,E,hp s  es[:]Ts; P,hp s  t √t 
   Ts'. P,E,hp s'  es'[:]Ts'  P  Ts' [≤] Ts"
proof (induct arbitrary: T E and Ts E rule:red_reds.inducts)
  case RedNew
  thus ?case by(auto dest: allocate_SomeD)
next
  case RedNewFail thus ?case unfolding sconf_def
    by(fastforce intro:typeof_OutOfMemory preallocated_heap_ops simp add: xcpt_subcls_Throwable[OF _ wf]) 
next
  case NewArrayRed
  thus ?case by fastforce
next
  case RedNewArray
  thus ?case by(auto dest: allocate_SomeD)
next
  case RedNewArrayNegative thus ?case unfolding sconf_def
    by(fastforce intro: preallocated_heap_ops simp add: xcpt_subcls_Throwable[OF _ wf]) 
next
  case RedNewArrayFail thus ?case unfolding sconf_def
    by(fastforce intro:typeof_OutOfMemory preallocated_heap_ops simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case (CastRed e s ta e' s' C T E)
  have esse: "extTA,P,t  e,s -ta e',s'" 
    and IH: "T E. E  s ; P,E,hp s  e : T; P,hp s  t √t  T'. P,E,hp s'  e' : T'  P  T'  T"
    and hconf: "E  s "
    and wtc: "P,E,hp s  Cast C e : T" by fact+
  thus ?case
  proof(clarsimp)
    fix T'
    assume wte: "P,E,hp s  e : T'" "is_type P C"
    from wte and hconf and IH and P,hp s  t √t have "U. P,E,hp s'  e' : U  P  U  T'" by simp
    then obtain U where wtee: "P,E,hp s'  e' : U" and UsTT: "P  U  T'" by blast
    from wtee ‹is_type P C have "P,E,hp s'  Cast C e' : C" by(rule WTrtCast)
    thus "T'. P,E,hp s'  Cast C e' : T'  P  T'  C" by blast
  qed
next
  case RedCast thus ?case
    by(clarsimp simp add: is_refT_def)
next
  case RedCastFail thus ?case unfolding sconf_def
    by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case (InstanceOfRed e s ta e' s' U T E)
  have IH: "T E. E  s ; P,E,hp s  e : T; P,hp s  t √t  T'. P,E,hp s'  e' : T'  P  T'  T"
    and hconf: "E  s "
    and wtc: "P,E,hp s  e instanceof U : T" 
    and tconf: "P,hp s  t √t" by fact+
  from wtc obtain T' where "P,E,hp s  e : T'" by auto
  from IH[OF hconf this tconf] obtain T'' where "P,E,hp s'  e' : T''" by auto
  with wtc show ?case by auto
next
  case RedInstanceOf thus ?case
    by(clarsimp)
next
  case (BinOpRed1 e1 s ta e1' s' bop e2 T E)
  have red: "extTA,P,t  e1, s -ta e1', s'"
   and IH: "T E. E  s ; P,E,hp s  e1:T; P,hp s  t √t
                  U. P,E,hp s'  e1' : U  P  U  T"
   and conf: "E  s " and wt: "P,E,hp s  e1 «bop» e2 : T" 
   and tconf: "P,hp s  t √t" by fact+
  from wt obtain T1 T2 where wt1: "P,E,hp s  e1 : T1"
    and wt2: "P,E,hp s  e2 : T2" and wtbop: "P  T1«bop»T2 : T" by auto
  from IH[OF conf wt1 tconf] obtain T1' where wt1': "P,E,hp s'  e1' : T1'"
    and sub: "P  T1'  T1" by blast
  from WTrt_binop_widen_mono[OF wtbop sub widen_refl]
  obtain T' where wtbop': "P  T1'«bop»T2 : T'" and sub': "P  T'  T" by blast
  from wt1' WTrt_hext_mono[OF wt2 red_hext_incr[OF red]] wtbop'
  have "P,E,hp s'  e1' «bop» e2 : T'" by(rule WTrtBinOp)
  with sub' show ?case by blast
next
  case (BinOpRed2 e2 s ta e2' s' v1 bop T E)
  have red: "extTA,P,t  e2,s -ta e2',s'" by fact
  have IH: "E T. E  s ; P,E,hp s  e2:T; P,hp s  t √t
                  U. P,E,hp s'  e2' : U  P  U  T" 
    and tconf: "P,hp s  t √t" by fact+
  have conf: "E  s " and wt: "P,E,hp s  (Val v1) «bop» e2 : T" by fact+
  from wt obtain T1 T2 where wt1: "P,E,hp s  Val v1 : T1"
    and wt2: "P,E,hp s  e2 : T2" and wtbop: "P  T1«bop»T2 : T" by auto
  from IH[OF conf wt2 tconf] obtain T2' where wt2': "P,E,hp s'  e2' : T2'"
    and sub: "P  T2'  T2" by blast
  from WTrt_binop_widen_mono[OF wtbop widen_refl sub]
  obtain T' where wtbop': "P  T1«bop»T2' : T'" and sub': "P  T'  T" by blast
  from WTrt_hext_mono[OF wt1 red_hext_incr[OF red]] wt2' wtbop'
  have "P,E,hp s'  Val v1 «bop» e2' : T'" by(rule WTrtBinOp)
  with sub' show ?case by blast
next
  case (RedBinOp bop v1 v2 v s)
  from E  s  have preh: "preallocated (hp s)" by(cases s)(simp add: sconf_def)
  from P,E,hp s  Val v1 «bop» Val v2 : T obtain T1 T2
    where "typeofhp s v1 = T1" "typeofhp s v2 = T2" "P  T1«bop»T2 : T" by auto
  with wf preh have "P,hp s  v :≤ T" using ‹binop bop v1 v2 = Inl v
    by(rule binop_type)
  thus ?case by(auto simp add: conf_def)
next
  case (RedBinOpFail bop v1 v2 a s)
  from E  s  have preh: "preallocated (hp s)" by(cases s)(simp add: sconf_def)
  from P,E,hp s  Val v1 «bop» Val v2 : T obtain T1 T2
    where "typeofhp s v1 = T1" "typeofhp s v2 = T2" "P  T1«bop»T2 : T" by auto
  with wf preh have "P,hp s  Addr a :≤ Class Throwable" using ‹binop bop v1 v2 = Inr a
    by(rule binop_type)
  thus ?case by(auto simp add: conf_def)
next
  case RedVar thus ?case by (fastforce simp:sconf_def lconf_def conf_def)
next
  case LAssRed thus ?case by(blast intro:widen_trans)
next
  case RedLAss thus ?case by fastforce
next
  case (AAccRed1 a s ta a' s' i T E)
  have IH: "E T. E  s ; P,E,hp s  a : T; P,hp s  t √t  T'. P,E,hp s'  a' : T'  P  T'  T"
    and assa: "extTA,P,t  a,s -ta a',s'"
    and wt: "P,E,hp s  ai : T"
    and hconf: "E  s " 
    and tconf: "P,hp s  t √t" by fact+
  from wt have wti: "P,E,hp s  i : Integer" by auto
  from wti red_hext_incr[OF assa] have wti': "P,E,hp s'  i : Integer" by - (rule WTrt_hext_mono)
  { assume wta: "P,E,hp s  a : T⌊⌉"
    from IH[OF hconf wta tconf]
    obtain U where wta': "P,E,hp s'  a' : U" and UsubT: "P  U  T⌊⌉" by fastforce
    with wta' wti' have ?case by(cases U, auto simp add: widen_Array) }
  moreover
  { assume wta: "P,E,hp s  a : NT"
    from IH[OF hconf wta tconf] have "P,E,hp s'  a' : NT" by fastforce
    from this wti' have ?case
      by(fastforce intro:WTrtAAccNT) }
  ultimately show ?case using wt by auto
next
  case (AAccRed2 i s ta i' s' a T E)
  have IH: "E T. E  s ; P,E,hp s  i : T; P,hp s  t √t  T'. P,E,hp s'  i' : T'  P  T'  T"
    and issi: "extTA,P,t  i,s -ta i',s'"
    and wt: "P,E,hp s  Val ai : T"
    and sconf: "E  s " 
    and tconf: "P,hp s  t √t" by fact+
  from wt have wti: "P,E,hp s  i : Integer" by auto
  from wti IH sconf tconf have wti': "P,E,hp s'  i' : Integer" by blast
  from wt show ?case
  proof (rule WTrt_elim_cases)
    assume wta: "P,E,hp s  Val a : T⌊⌉"
    from wta red_hext_incr[OF issi] have wta': "P,E,hp s'  Val a : T⌊⌉" by (rule WTrt_hext_mono)
    from wta' wti' show ?case by(fastforce)
  next
    assume wta: "P,E,hp s  Val a : NT"
    from wta red_hext_incr[OF issi] have wta': "P,E,hp s'  Val a : NT" by (rule WTrt_hext_mono)
    from wta' wti' show ?case
      by(fastforce elim:WTrtAAccNT)
  qed
next
  case RedAAccNull thus ?case unfolding sconf_def
    by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case RedAAccBounds thus ?case unfolding sconf_def
    by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case (RedAAcc h a T n i v l T' E)
  from E  (h, l)  have "hconf h" by(clarsimp simp add: sconf_def)
  from 0 <=s i ‹sint i < int n
  have "nat (sint i) < n"
    by (simp add: word_sle_eq nat_less_iff)
  with typeof_addr h a = Array_type T n have "P,h  a@ACell (nat (sint i)) : T"
    by(auto intro: addr_loc_type.intros)
  from heap_read_conf[OF heap_read h a (ACell (nat (sint i))) v this] hconf h
  have "P,h  v :≤ T" by simp
  thus ?case using RedAAcc by(auto simp add: conf_def)
next
  case (AAssRed1 a s ta a' s' i e T E)
  have IH: "E T. E  s ; P,E,hp s  a : T; P,hp s  t √t  T'. P,E,hp s'  a' : T'  P  T'  T"
    and assa: "extTA,P,t  a,s -ta a',s'"
    and wt: "P,E,hp s  ai := e : T"
    and sconf: "E  s " 
    and tconf: "P,hp s  t √t" by fact+
  from wt have void: "T = Void" by blast
  from wt have wti: "P,E,hp s  i : Integer" by auto
  from wti red_hext_incr[OF assa] have wti': "P,E,hp s'  i : Integer" by - (rule WTrt_hext_mono)
  { assume wta: "P,E,hp s  a : NT"
    from IH[OF sconf wta tconf] have wta': "P,E,hp s'  a' : NT" by fastforce
    from wt wta obtain V where wte: "P,E,hp s  e : V" by(auto)
    from wte red_hext_incr[OF assa] have wte': "P,E,hp s'  e : V" by - (rule WTrt_hext_mono)
    from wta' wti' wte' void have ?case
      by(fastforce elim: WTrtAAssNT) }
  moreover
  { fix U
    assume wta: "P,E,hp s  a : U⌊⌉"
    from IH[OF sconf wta tconf]
    obtain U' where wta': "P,E,hp s'  a' : U'" and UsubT: "P  U'  U⌊⌉" by fastforce
    with wta' have ?case
    proof(cases U')
      case NT
      assume UNT: "U' = NT"
      from UNT wt wta obtain V where wte: "P,E,hp s  e : V" by(auto)
      from wte red_hext_incr[OF assa] have wte': "P,E,hp s'  e : V" by - (rule WTrt_hext_mono)
      from wta' UNT wti' wte' void show ?thesis
        by(fastforce elim: WTrtAAssNT)
    next
      case (Array A)
      have UA: "U' = A⌊⌉" by fact
      with UA UsubT wt wta obtain V where wte: "P,E,hp s  e : V" by auto
      from wte red_hext_incr[OF assa] have wte': "P,E,hp s'  e : V" by - (rule WTrt_hext_mono)
      with wta' wte' UA wti' void show ?thesis by (fast elim:WTrtAAss)
    qed(simp_all add: widen_Array) }
  ultimately show ?case using wt by blast
next
  case (AAssRed2 i s ta i' s' a e T E)
  have IH: "E T. E  s ; P,E,hp s  i : T; P,hp s  t √t   T'. P,E,hp s'  i' : T'  P  T'  T" 
    and issi: "extTA,P,t  i,s -ta i',s'" 
    and wt: "P,E,hp s  Val ai := e : T" 
    and sconf: "E  s " and tconf: "P,hp s  t √t" by fact+
  from wt have void: "T = Void" by blast
  from wt have wti: "P,E,hp s  i : Integer" by auto
  from IH[OF sconf wti tconf] have wti': "P,E,hp s'  i' : Integer" by fastforce
  from wt show ?case
  proof(rule WTrt_elim_cases)
    fix U T'
    assume wta: "P,E,hp s  Val a : U⌊⌉"
      and wte: "P,E,hp s  e : T'"
    from wte red_hext_incr[OF issi] have wte': "P,E,hp s'  e : T'" by - (rule WTrt_hext_mono)
    from wta red_hext_incr[OF issi] have wta': "P,E,hp s'  Val a : U⌊⌉" by - (rule WTrt_hext_mono)
    from wta' wti' wte' void show ?case by (fastforce elim:WTrtAAss)
  next
    fix T'
    assume wta: "P,E,hp s  Val a : NT"
      and wte: "P,E,hp s  e : T'"
    from wte red_hext_incr[OF issi] have wte': "P,E,hp s'  e : T'" by - (rule WTrt_hext_mono)
    from wta red_hext_incr[OF issi] have wta': "P,E,hp s'  Val a : NT" by - (rule WTrt_hext_mono)
    from wta' wti' wte' void show ?case by (fastforce elim:WTrtAAss)
  qed
next
  case (AAssRed3 e s ta e' s' a i T E)
  have IH: "E T. E  s ; P,E,hp s  e : T; P,hp s  t √t  T'. P,E,hp s'  e' : T'  P  T'  T" 
    and issi: "extTA,P,t  e,s -ta e',s'" 
    and wt: "P,E,hp s  Val aVal i := e : T" 
    and sconf: "E  s " and tconf: "P,hp s  t √t" by fact+
  from wt have void: "T = Void" by blast
  from wt have wti: "P,E,hp s  Val i : Integer" by auto
  from wti red_hext_incr[OF issi] have wti': "P,E,hp s'  Val i : Integer" by - (rule WTrt_hext_mono)
  from wt show ?case
  proof(rule WTrt_elim_cases)
    fix U T'
    assume wta: "P,E,hp s  Val a : U⌊⌉"
      and wte: "P,E,hp s  e : T'"
    from wta red_hext_incr[OF issi] have wta': "P,E,hp s'  Val a : U⌊⌉" by - (rule WTrt_hext_mono)
    from IH[OF sconf wte tconf]
    obtain V where wte': "P,E,hp s'  e' : V" by fastforce
    from wta' wti' wte' void show ?case by (fastforce elim:WTrtAAss)
  next
    fix T'
    assume wta: "P,E,hp s  Val a : NT"
      and wte: "P,E,hp s  e : T'"
    from wta red_hext_incr[OF issi] have wta': "P,E,hp s'  Val a : NT" by - (rule WTrt_hext_mono)
    from IH[OF sconf wte tconf]
    obtain V where wte': "P,E,hp s'  e' : V" by fastforce
    from wta' wti' wte' void show ?case by (fastforce elim:WTrtAAss)
  qed
next
  case RedAAssNull thus ?case unfolding sconf_def
    by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case RedAAssBounds thus ?case unfolding sconf_def
    by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case RedAAssStore thus ?case unfolding sconf_def
    by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case RedAAss thus ?case
    by(auto simp del:fun_upd_apply)
next
  case (ALengthRed a s ta a' s' T E)
  note IH = T'. E  s ; P,E,hp s  a : T'; P,hp s  t √t
       T''. P,E,hp s'  a' : T''  P  T''  T'
  from P,E,hp s  a∙length : T
  show ?case
  proof(rule WTrt_elim_cases)
    fix T'
    assume [simp]: "T = Integer"
      and wta: "P,E,hp s  a : T'⌊⌉"
    from wta E  s  IH P,hp s  t √t
    obtain T'' where wta': "P,E,hp s'  a' : T''" 
      and sub: "P  T''  T'⌊⌉" by blast
    from sub have "P,E,hp s'  a'∙length : Integer"
      unfolding widen_Array
    proof(rule disjE)
      assume "T'' = NT"
      with wta' show ?thesis by(auto)
    next
      assume "V. T'' = V⌊⌉  P  V  T'"
      then obtain V where "T'' = V⌊⌉" "P  V  T'" by blast
      with wta' show ?thesis by -(rule WTrtALength, simp)
    qed
    thus ?thesis by(simp)
  next
    assume "P,E,hp s  a : NT"
    with E  s  IH P,hp s  t √t
    obtain T'' where wta': "P,E,hp s'  a' : T''" 
      and sub: "P  T''  NT" by blast
    from sub have "T'' = NT" by auto
    with wta' show ?thesis by(auto)
  qed
next
  case (RedALength h a T n l T' E)
  from P,E,hp (h, l)  addr a∙length : T' typeof_addr h a = Array_type T n
  have [simp]: "T' = Integer" by(auto)
  thus ?case by(auto)
next
  case RedALengthNull thus ?case unfolding sconf_def
    by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case (FAccRed e s ta e' s' F D T E)
  have IH: "E T. E  s ; P,E,hp s  e : T; P,hp s  t √t
                  U. P,E,hp s'  e' : U  P  U  T"
   and conf: "E  s " and wt: "P,E,hp s  eF{D} : T" 
   and tconf: "P,hp s  t √t" by fact+
  ― ‹Now distinguish the two cases how wt can have arisen.›
  { fix T' C fm
    assume wte: "P,E,hp s  e : T'"
      and icto: "class_type_of' T' = C"
      and has: "P  C has F:T (fm) in D"
    from IH[OF conf wte tconf]
    obtain U where wte': "P,E,hp s'  e' : U" and UsubC: "P  U  T'" by auto
    ― ‹Now distinguish what @{term U} can be.›
    with UsubC have ?case
    proof(cases "U = NT")
      case True
      thus ?thesis using wte' by(blast intro:WTrtFAccNT widen_refl) 
    next
      case False
      with icto UsubC obtain C' where icto': "class_type_of' U = C'"
        and C'subC: "P  C' * C"
        by(rule widen_is_class_type_of)
      from has_field_mono[OF has C'subC] wte' icto'
      show ?thesis by(auto intro!:WTrtFAcc) 
    qed }
  moreover
  { assume "P,E,hp s  e : NT"
    hence "P,E,hp s'  e' : NT" using IH[OF conf _ tconf] by fastforce
    hence ?case  by(fastforce intro:WTrtFAccNT widen_refl) }
  ultimately show ?case using wt by blast
next
  case RedFAcc thus ?case unfolding sconf_def
    by(fastforce dest: heap_read_conf intro: addr_loc_type.intros simp add: conf_def)
next
  case RedFAccNull thus ?case unfolding sconf_def
    by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case (FAssRed1 e s ta e' s' F D e2)
  have red: "extTA,P,t  e,s -ta e',s'"
   and IH: "E T. E  s ; P,E,hp s  e : T; P,hp s  t √t
                  U. P,E,hp s'  e' : U  P  U  T"
   and conf: "E  s " and wt: "P,E,hp s  eF{D}:=e2 : T"
   and tconf: "P,hp s  t √t" by fact+
  from wt have void: "T = Void" by blast
  ― ‹We distinguish if @{term e} has type @{term NT} or a Class type›
  { assume "P,E,hp s  e : NT"
    hence "P,E,hp s'  e' : NT" using IH[OF conf _ tconf] by fastforce
    moreover obtain T2 where "P,E,hp s  e2 : T2" using wt by auto
    from this red_hext_incr[OF red] have  "P,E,hp s'  e2 : T2"
      by(rule WTrt_hext_mono)
    ultimately have ?case using void by(blast intro!:WTrtFAssNT)
  }
  moreover
  { fix T' C TF T2 fm
    assume wt1: "P,E,hp s  e : T'" and icto: "class_type_of' T' = C" and wt2: "P,E,hp s  e2 : T2"
      and has: "P  C has F:TF (fm) in D" and sub: "P  T2  TF"
    obtain U where wt1': "P,E,hp s'  e' : U" and UsubC: "P  U  T'"
      using IH[OF conf wt1 tconf] by blast
    have wt2': "P,E,hp s'  e2 : T2"
      by(rule WTrt_hext_mono[OF wt2 red_hext_incr[OF red]])
    ― ‹Is @{term U} the null type or a class type?›
    have ?case
    proof(cases "U = NT")
      case True
      with wt1' wt2' void show ?thesis by(blast intro!:WTrtFAssNT)
    next
      case False
      with icto UsubC obtain C' where icto': "class_type_of' U = C'"
        and "subclass": "P  C' * C" by(rule widen_is_class_type_of)
      have "P  C' has F:TF (fm) in D" by(rule has_field_mono[OF has "subclass"])
      with wt1' show ?thesis using wt2' sub void icto' by(blast intro:WTrtFAss)
    qed }
  ultimately show ?case using wt by blast
next
  case (FAssRed2 e2 s ta e2' s' v F D T E)
  have red: "extTA,P,t  e2,s -ta e2',s'"
   and IH: "E T. E  s ; P,E,hp s  e2 : T; P,hp s  t √t
                  U. P,E,hp s'  e2' : U  P  U  T"
   and conf: "E  s " and wt: "P,E,hp s  Val vF{D}:=e2 : T" 
   and tconf: "P,hp s  t √t" by fact+
  from wt have [simp]: "T = Void" by auto
  from wt show ?case
  proof (rule WTrt_elim_cases)
    fix U C TF T2 fm
    assume wt1: "P,E,hp s  Val v : U"
      and icto: "class_type_of' U = C"
      and has: "P  C has F:TF (fm) in D"
      and wt2: "P,E,hp s  e2 : T2" and TsubTF: "P  T2  TF"
    have wt1': "P,E,hp s'  Val v : U"
      by(rule WTrt_hext_mono[OF wt1 red_hext_incr[OF red]])
    obtain T2' where wt2': "P,E,hp s'  e2' : T2'" and T'subT: "P  T2'  T2"
      using IH[OF conf wt2 tconf] by blast
    have "P,E,hp s'  Val vF{D}:=e2' : Void"
      by(rule WTrtFAss[OF wt1' icto has wt2' widen_trans[OF T'subT TsubTF]])
    thus ?case by auto
  next
    fix T2 assume null: "P,E,hp s  Val v : NT" and wt2: "P,E,hp s  e2 : T2"
    from null have "v = Null" by simp
    moreover
    obtain T2' where "P,E,hp s'  e2' : T2'  P  T2'  T2"
      using IH[OF conf wt2 tconf] by blast
    ultimately show ?thesis by(fastforce intro:WTrtFAssNT)
  qed
next
  case RedFAss thus ?case by(auto simp del:fun_upd_apply)
next
  case RedFAssNull thus ?case unfolding sconf_def
    by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case (CASRed1 e s ta e' s' D F e2 e3)
  from CASRed1.prems(2) consider (NT) T2 T3 where 
      "P,E,hp s  e : NT" "T = Boolean" "P,E,hp s  e2 : T2" "P,E,hp s  e3 : T3"
    | (RefT) U T' C fm T2 T3 where
      "P,E,hp s  e : U" "T = Boolean" "class_type_of' U = C" "P  C has F:T' (fm) in D"
      "P,E,hp s  e2 : T2" "P  T2  T'" "P,E,hp s  e3 : T3" "P  T3  T'" "volatile fm" by fastforce
  thus ?case
  proof cases
    case NT
    have "P,E,hp s'  e' : NT" using CASRed1.hyps(2)[OF CASRed1.prems(1) NT(1) CASRed1.prems(3)] by auto
    moreover from NT CASRed1.hyps(1)[THEN red_hext_incr]
    have "P,E,hp s'  e2 : T2" "P,E,hp s'  e3 : T3" by(auto intro: WTrt_hext_mono)
    ultimately show ?thesis using NT by(auto intro: WTrtCASNT)
  next
    case RefT
    from CASRed1.hyps(2)[OF CASRed1.prems(1) RefT(1) CASRed1.prems(3)]
    obtain U' where wt1: "P,E,hp s'  e' : U'" "P  U'  U" by blast
    from RefT CASRed1.hyps(1)[THEN red_hext_incr]
    have wt2: "P,E,hp s'  e2 : T2" and wt3: "P,E,hp s'  e3 : T3" by(auto intro: WTrt_hext_mono)
    show ?thesis
    proof(cases "U' = NT")
      case True
      with RefT wt1 wt2 wt3 show ?thesis by(auto intro: WTrtCASNT)
    next
      case False
      with RefT(3) wt1 obtain C' where icto': "class_type_of' U' = C'"
        and "subclass": "P  C' * C" by(blast intro: widen_is_class_type_of)
      have "P  C' has F:T' (fm) in D" by(rule has_field_mono[OF RefT(4) "subclass"])
      with RefT wt1 wt2 wt3 icto' show ?thesis by(auto intro!: WTrtCAS)
    qed
  qed
next
  case (CASRed2 e s ta e' s' v D F e3)
  consider (Null) "v = Null" | (Val) U C T' fm T2 T3 where
    "class_type_of' U = C" "P  C has F:T' (fm) in D" "volatile fm"
    "P,E,hp s  e : T2" "P  T2  T'" "P,E,hp s  e3 : T3" "P  T3  T'" "T = Boolean"
    "typeofhp s v = U" using CASRed2.prems(2) by auto
  then show ?case 
  proof cases
    case Null
    then show ?thesis using CASRed2 
      by(force dest: red_hext_incr intro: WTrt_hext_mono WTrtCASNT)
  next
    case Val
    from CASRed2.hyps(1) have hext: "hp s  hp s'" by(auto dest: red_hext_incr)
    with Val(9) have "typeofhp s' v = U" by(rule type_of_hext_type_of)
    moreover from CASRed2.hyps(2)[OF CASRed2.prems(1) Val(4) CASRed2.prems(3)] Val(5)
    obtain T2' where "P,E,hp s'  e' : T2'" "P  T2'  T'" by(auto intro: widen_trans)
    moreover from Val(6) hext have "P,E,hp s'  e3 : T3" by(rule WTrt_hext_mono)
    ultimately show ?thesis using Val by(auto intro: WTrtCAS)
  qed
next
  case (CASRed3 e s ta e' s' v D F v')
  consider (Null) "v = Null" | (Val) U C T' fm T2 T3 where 
    "T = Boolean" "class_type_of' U = C" "P  C has F:T' (fm) in D" "volatile fm"
    "P  T2  T'" "P,E,hp s  e : T3" "P  T3  T'"
    "typeofhp s v = U" "typeofhp s v' = T2"
    using CASRed3.prems(2) by auto
  then show ?case
  proof cases
    case Null
    then show ?thesis using CASRed3
      by(force dest: red_hext_incr intro: type_of_hext_type_of WTrtCASNT)
  next
    case Val
    from CASRed3.hyps(1) have hext: "hp s  hp s'" by(auto dest: red_hext_incr)
    with Val(8,9) have "typeofhp s' v = U" "typeofhp s' v' = T2"
      by(blast intro: type_of_hext_type_of)+
    moreover from CASRed3.hyps(2)[OF CASRed3.prems(1) Val(6) CASRed3.prems(3)] Val(7)
    obtain T3' where "P,E,hp s'  e' : T3'" "P  T3'  T'" by(auto intro: widen_trans)
    ultimately show ?thesis using Val by(auto intro: WTrtCAS)
  qed
next
  case CASNull thus ?case unfolding sconf_def
    by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case (CallObj e s ta e' s' M es T E)
  have red: "extTA,P,t  e,s -ta e',s'"
   and IH: "E T. E  s ; P,E,hp s  e : T; P,hp s  t √t
                  U. P,E,hp s'  e' : U  P  U  T"
   and conf: "E  s " and wt: "P,E,hp s  eM(es) : T"
   and tconf: "P,hp s  t √t" by fact+
  ― ‹We distinguish if @{term e} has type @{term NT} or a Class type›
  from wt show ?case
  proof(rule WTrt_elim_cases)
    fix T' C Ts meth D Us
    assume wte: "P,E,hp s  e : T'" and icto: "class_type_of' T' = C"
      and "method": "P  C sees M:TsT = meth in D"
      and wtes: "P,E,hp s  es [:] Us" and subs: "P  Us [≤] Ts"
    obtain U where wte': "P,E,hp s'  e' : U" and UsubC: "P  U  T'"
      using IH[OF conf wte tconf] by blast
    show ?thesis
    proof(cases "U = NT")
      case True
      moreover have "P,E,hp s'  es [:] Us"
        by(rule WTrts_hext_mono[OF wtes red_hext_incr[OF red]])
      ultimately show ?thesis using wte' by(blast intro!:WTrtCallNT)
    next
      case False
      with icto UsubC obtain C'
        where icto': "class_type_of' U = C'" and "subclass": "P  C' * C"
        by(rule widen_is_class_type_of)

      obtain Ts' T' meth' D'
        where method': "P  C' sees M:Ts'T' = meth' in D'"
        and subs': "P  Ts [≤] Ts'" and sub': "P  T'  T"
        using Call_lemma[OF "method" "subclass" wf] by fast
      have wtes': "P,E,hp s'  es [:] Us"
        by(rule WTrts_hext_mono[OF wtes red_hext_incr[OF red]])
      show ?thesis using wtes' wte' icto' subs method' subs' sub' by(blast intro:widens_trans)
    qed
  next
    fix Ts
    assume "P,E,hp s  e:NT"
    hence "P,E,hp s'  e' : NT" using IH[OF conf _ tconf] by fastforce
    moreover
    fix Ts assume wtes: "P,E,hp s  es [:] Ts"
    have "P,E,hp s'  es [:] Ts"
      by(rule WTrts_hext_mono[OF wtes red_hext_incr[OF red]])
    ultimately show ?thesis by(blast intro!:WTrtCallNT)
  qed
next
  case (CallParams es s ta es' s' v M T E)
  have reds: "extTA,P,t  es,s [-ta→] es',s'"
   and IH: "Ts E. E  s ; P,E,hp s  es [:] Ts; P,hp s  t √t
            Ts'. P,E,hp s'  es' [:] Ts'  P  Ts' [≤] Ts"
   and conf: "E  s " and wt: "P,E,hp s  Val vM(es) : T" 
   and tconf: "P,hp s  t √t" by fact+
  from wt show ?case
  proof (rule WTrt_elim_cases)
    fix U C Ts meth D Us
    assume wte: "P,E,hp s  Val v : U" and icto: "class_type_of' U = C"
      and "P  C sees M:TsT = meth in D"
      and wtes: "P,E,hp s  es [:] Us" and "P  Us [≤] Ts"
    moreover have "P,E,hp s'  Val v : U"
      by(rule WTrt_hext_mono[OF wte reds_hext_incr[OF reds]])
    moreover obtain Us' where "P,E,hp s'  es' [:] Us'" "P  Us' [≤] Us"
      using IH[OF conf wtes tconf] by blast
    ultimately show ?thesis by(fastforce intro:WTrtCall widens_trans)
  next
    fix Us
    assume null: "P,E,hp s  Val v : NT" and wtes: "P,E,hp s  es [:] Us"
    from null have "v = Null" by simp
    moreover
    obtain Us' where "P,E,hp s'  es' [:] Us'  P  Us' [≤] Us"
      using IH[OF conf wtes tconf] by blast
    ultimately show ?thesis by(fastforce intro:WTrtCallNT)
  qed
next
  case (RedCall s a U M Ts T pns body D vs T' E)
  have hp: "typeof_addr (hp s) a = U"
    and "method": "P  class_type_of U sees M: TsT = (pns,body) in D"
    and wt: "P,E,hp s  addr aM(map Val vs) : T'" by fact+
  obtain Ts' where wtes: "P,E,hp s  map Val vs [:] Ts'"
    and subs: "P  Ts' [≤] Ts" and T'isT: "T' = T"
    using wt "method" hp wf by(auto 4 3 dest: sees_method_fun)
  from wtes subs have length_vs: "length vs = length Ts"
    by(auto simp add: WTrts_conv_list_all2 dest!: list_all2_lengthD)
  have UsubD: "P  ty_of_htype U  Class (class_type_of U)"
    by(cases U)(simp_all add: widen_array_object)
  from sees_wf_mdecl[OF wf "method"] obtain T''
    where wtabody: "P,[this#pns [↦] Class D#Ts]  body :: T''"
    and T''subT: "P  T''  T" and length_pns: "length pns = length Ts"
    by(fastforce simp:wf_mdecl_def simp del:map_upds_twist)
  from wtabody have "P,Map.empty(this#pns [↦] Class D#Ts),hp s  body : T''"
    by(rule WT_implies_WTrt)
  hence "P,E(this#pns [↦] Class D#Ts),hp s  body : T''"
    by(rule WTrt_env_mono) simp
  hence "P,E,hp s  blocks (this#pns) (Class D#Ts) (Addr a#vs) body : T''"
    using wtes subs hp sees_method_decl_above[OF "method"] length_vs length_pns UsubD
    by(auto simp add:wt_blocks rel_list_all2_Cons2 intro: widen_trans)
  with T''subT T'isT show ?case by blast
next
  case (RedCallExternal s a U M Ts T' D vs ta va h' ta' e' s')
  from P,t  aM(vs),hp s -ta→ext va,h' have "hp s  h'" by(rule red_external_hext)
  with P,E,hp s  addr aM(map Val vs) : T
  have "P,E,h'  addr aM(map Val vs) : T" by(rule WTrt_hext_mono)
  moreover from typeof_addr (hp s) a = U P  class_type_of U sees M: TsT' = Native in D P,E,hp s  addr aM(map Val vs) : T
  have "P,hp s  aM(vs) : T'"
    by(fastforce simp add: external_WT'_iff dest: sees_method_fun)
  ultimately show ?case using RedCallExternal
    by(auto 4 3 intro: red_external_conf_extRet[OF wf] intro!: wt_external_call simp add: sconf_def dest: sees_method_fun[where C="class_type_of U"])
next
  case RedCallNull thus ?case unfolding sconf_def
    by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case (BlockRed e h x V vo ta e' h' x' T T' E)
  note IH = T E. E  (h, x(V := vo)) ; P,E,hp (h, x(V := vo))  e : T; P,hp (h, x(V := vo))  t √t
              T'. P,E,hp (h', x')  e' : T'  P  T'  T[simplified]
  from P,E,hp (h, x)  {V:T=vo; e} : T' have "P,E(VT),h  e : T'" by(cases vo, auto)
  moreover from E  (h, x)  P,E,hp (h, x)  {V:T=vo; e} : T'
  have "(E(V  T))  (h, x(V := vo)) "
    by(cases vo)(simp add: lconf_def sconf_def,auto simp add: sconf_def conf_def intro: lconf_upd2)
  ultimately obtain T'' where wt': "P,E(VT),h'  e' : T''" "P  T''  T'" using P,hp (h, x)  t √t
    by(auto dest: IH)
  { fix v
    assume vo: "x' V = v"
    from (E(V  T))  (h, x(V := vo))  extTA,P,t  e,(h, x(V := vo)) -ta e',(h', x') P,E(VT),h  e : T'
    have "P,h'  x' (:≤) (E(V  T))" by(auto simp add: sconf_def dest: red_preserves_lconf)
    with vo have "T'. typeofh' v = T'  P  T'  T" by(fastforce simp add: sconf_def lconf_def conf_def)
    then obtain T' where "typeofh' v = T'" "P  T'  T" by blast
    hence ?case using wt' vo by(auto) }
  moreover
  { assume "x' V = None" with wt' have ?case by(auto) }
  ultimately show ?case by blast
next 
  case RedBlock thus ?case by auto
next
  case (SynchronizedRed1 o' s ta o'' s' e T E)
  have red: "extTA,P,t  o',s -ta o'',s'" by fact
  have IH: "T E. E  s ; P,E,hp s  o' : T; P,hp s  t √t  T'. P,E,hp s'  o'' : T'  P  T'  T" by fact
  have conf: "E  s " by fact
  have wt: "P,E,hp s  sync(o') e : T" by fact+
  thus ?case
  proof(rule WTrt_elim_cases)
    fix To
    assume wto: "P,E,hp s  o' : To"
      and refT: "is_refT To" 
      and wte: "P,E,hp s  e : T"
    from IH[OF conf wto P,hp s  t √t] obtain To' where "P,E,hp s'  o'' : To'" and sub: "P  To'  To" by auto
    moreover have "P,E,hp s'  e : T"
      by(rule WTrt_hext_mono[OF wte red_hext_incr[OF red]])
    moreover have "is_refT To'" using refT sub by(auto intro: widen_refT)
    ultimately show ?thesis by(auto)
  qed
next
  case SynchronizedNull thus ?case unfolding sconf_def
    by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case LockSynchronized thus ?case by(auto)
next
  case (SynchronizedRed2 e s ta e' s' a T E)
  have red: "extTA,P,t  e,s -ta e',s'" by fact
  have IH: "T E. E  s ; P,E,hp s  e : T; P,hp s  t √t  T'. P,E,hp s'  e' : T'  P  T'  T" by fact
  have conf: "E  s " by fact
  have wt: "P,E,hp s  insync(a) e : T" by fact
  thus ?case
  proof(rule WTrt_elim_cases)
    fix Ta
    assume "P,E,hp s  e : T"
      and hpa: "typeof_addr (hp s) a = Ta"
    from P,E,hp s  e : T conf P,hp s  t √t obtain T'
      where "P,E,hp s'  e' : T'" "P  T'  T" by(blast dest: IH)
    moreover from red have hext: "hp s  hp s'" by(auto dest: red_hext_incr)
    with hpa have "P,E,hp s'  addr a : ty_of_htype Ta"
      by(auto intro: typeof_addr_hext_mono)
    ultimately show ?thesis by auto
  qed
next
  case UnlockSynchronized thus ?case by(auto)
next
  case SeqRed thus ?case
    apply(auto)
    apply(drule WTrt_hext_mono[OF _ red_hext_incr], assumption)
    by auto
next
  case (CondRed b s ta b' s' e1 e2 T E)
  have red: "extTA,P,t  b,s -ta b',s'" by fact
  have IH: "T E. E  s ; P,E,hp s  b : T; P,hp s  t √t  T'. P,E,hp s'  b' : T'  P  T'  T" by fact
  have conf: "E  s " by fact
  have wt: "P,E,hp s  if (b) e1 else e2 : T" by fact
  thus ?case
  proof(rule WTrt_elim_cases)
    fix T1 T2
    assume wtb: "P,E,hp s  b : Boolean"
      and wte1: "P,E,hp s  e1 : T1"
      and wte2: "P,E,hp s  e2 : T2"
      and lub: "P  lub(T1, T2) = T"
    from IH[OF conf wtb P,hp s  t √t] have "P,E,hp s'  b' : Boolean" by(auto)
    moreover have "P,E,hp s'  e1 : T1"
      by(rule WTrt_hext_mono[OF wte1 red_hext_incr[OF red]])
    moreover have "P,E,hp s'  e2 : T2"
      by(rule WTrt_hext_mono[OF wte2 red_hext_incr[OF red]])
    ultimately show ?thesis using lub by auto
  qed
next
  case (ThrowRed e s ta e' s' T E)
  have IH: "T E. E  s ; P,E,hp s  e : T; P,hp s  t √t  T'. P,E,hp s'  e' : T'  P  T'  T" by fact
  have conf: "E  s " by fact
  have wt: "P,E,hp s  throw e : T" by fact
  then obtain T'
    where wte: "P,E,hp s  e : T'" 
    and nobject: "P  T'  Class Throwable" by auto
  from IH[OF conf wte P,hp s  t √t] obtain T'' 
    where wte': "P,E,hp s'  e' : T''"
    and PT'T'': "P  T''  T'" by blast
  from nobject PT'T'' have "P  T''  Class Throwable"
    by(auto simp add: widen_Class)(erule notE, rule rtranclp_trans)
  hence "P,E,hp s'  throw e' : T" using wte' PT'T''
    by -(erule WTrtThrow)
  thus ?case by(auto)
next
  case RedThrowNull thus ?case unfolding sconf_def
    by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case (TryRed e s ta e' s' C V e2 T E)
  have red: "extTA,P,t  e,s -ta e',s'" by fact
  have IH: "T E. E  s ; P,E,hp s  e : T; P,hp s  t √t  T'. P,E,hp s'  e' : T'  P  T'  T" by fact
  have conf: "E  s " by fact
  have wt: "P,E,hp s  try e catch(C V) e2 : T" by fact
  thus ?case
  proof(rule WTrt_elim_cases)
    fix T1
    assume wte: "P,E,hp s  e : T1"
      and wte2: "P,E(V  Class C),hp s  e2 : T"
      and sub: "P  T1  T"
    from IH[OF conf wte P,hp s  t √t] obtain T1' where "P,E,hp s'  e' : T1'" and "P  T1'  T1" by(auto)
    moreover have "P,E(V  Class C),hp s'  e2 : T"
      by(rule WTrt_hext_mono[OF wte2 red_hext_incr[OF red]])
    ultimately show ?thesis using sub by(auto elim: widen_trans)
  qed
next
  case RedTryFail thus ?case unfolding sconf_def
    by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case RedSeq thus ?case by auto
next
  case RedCondT thus ?case by(auto dest: is_lub_upper)
next
  case RedCondF thus ?case by(auto dest: is_lub_upper)
next
  case RedWhile thus ?case by(fastforce) 
next
  case RedTry thus ?case by auto
next
  case RedTryCatch thus ?case by(fastforce)
next
  case (ListRed1 e s ta e' s' es Ts E)
  note IH = T E. E  s ; P,E,hp s  e : T; P,hp s  t √t  T'. P,E,hp s'  e' : T'  P  T'  T
  from P,E,hp s  e # es [:] Ts obtain T Ts' where "Ts = T # Ts'" "P,E,hp s  e : T" "P,E,hp s  es [:] Ts'" by auto
  with IH[of E T] E  s  WTrts_hext_mono[OF P,E,hp s  es [:] Ts' red_hext_incr[OF extTA,P,t  e,s -ta e',s']]
  show ?case using P,hp s  t √t by(auto simp add: list_all2_Cons2 intro: widens_refl)
next
  case ListRed2 thus ?case
    by(fastforce dest: hext_typeof_mono[OF reds_hext_incr])
qed(fastforce)+

end

Theory ProgressThreaded

(*  Title:      JinjaThreads/J/ProgressThreaded.thy
    Author:     Andreas Lochbihler
*)

section ‹Progress and type safety theorem for the multithreaded system›

theory ProgressThreaded 
imports 
  Threaded
  TypeSafe
  "../Framework/FWProgress"
begin

lemma lock_ok_ls_Some_ex_ts_not_final:
  assumes lock: "lock_ok ls ts"
  and hl: "has_lock (ls $ l) t"
  shows "e x ln. ts t = ((e, x), ln)  ¬ final e"
proof -
  from lock have "lock_thread_ok ls ts"
    by(rule lock_ok_lock_thread_ok)
  with hl obtain e x ln
    where tst: "ts t = ((e, x), ln)"
    by(auto dest!: lock_thread_okD)
  { assume "final e"
    hence "expr_locks e l = 0" by(rule final_locks)
    with lock tst have "has_locks (ls $ l) t = 0"
      by(auto dest: lock_okD2[rule_format, where l=l])
    with hl have False by simp }
  with tst show ?thesis by auto
qed

subsection ‹Preservation lemmata›

subsection ‹Definite assignment›

abbreviation
  def_ass_ts_ok :: "('addr,'thread_id,'addr expr × 'addr locals) thread_info  'heap  bool"
where
  "def_ass_ts_ok  ts_ok (λt (e, x) h. 𝒟 e dom x)"

context J_heap_base begin

lemma assumes wf: "wf_J_prog P"
  shows red_def_ass_new_thread:
  " P,t  e, s -ta e', s'; NewThread t'' (e'', x'') c''  set tat   𝒟 e'' dom x''"
  
  and reds_def_ass_new_thread:
  " P,t  es, s [-ta→] es', s'; NewThread t'' (e'', x'') c''  set tat   𝒟 e'' dom x''"
proof(induct rule: red_reds.inducts)
  case (RedCallExternal s a T M vs ta va h' ta' e' s')
  then obtain C fs a where subThread: "P  C * Thread" and ext: "extNTA2J P (C, run, a) = (e'', x'')"
    by(fastforce dest: red_external_new_thread_sub_thread)
  from sub_Thread_sees_run[OF wf subThread] obtain D pns body
    where sees: "P  C sees run: []Void = (pns, body) in D" by auto
  from sees_wf_mdecl[OF wf this] have "𝒟 body {this}"
    by(auto simp add: wf_mdecl_def)
  with sees ext show ?case by(clarsimp simp del: fun_upd_apply)
qed(auto simp add: ta_upd_simps)

lemma lifting_wf_def_ass: "wf_J_prog P  lifting_wf final_expr (mred P) (λt (e, x) m. 𝒟 e dom x)"
apply(unfold_locales)
apply(auto dest: red_preserves_defass red_def_ass_new_thread)
done

lemma def_ass_ts_ok_J_start_state:
  " wf_J_prog P; P  C sees M:TsT = (pns, body) in D; length vs = length Ts  
  def_ass_ts_ok (thr (J_start_state P C M vs)) h"
apply(rule ts_okI)
apply(drule (1) sees_wf_mdecl)
apply(clarsimp simp add: wf_mdecl_def start_state_def split: if_split_asm)
done

end

subsection ‹typeability›

context J_heap_base begin

definition type_ok :: "'addr J_prog  env × ty  'addr expr  'heap  bool"
where "type_ok P  (λ(E, T) e c. (T'. (P,E,c  e : T'  P  T'  T)))"

definition J_sconf_type_ET_start :: "'m prog  cname  mname  ('thread_id  (env × ty))"
where
  "J_sconf_type_ET_start P C M 
   let (_, _, T, _) = method P C M
   in ([start_tid  (Map.empty, T)])"

lemma fixes E :: env
  assumes wf: "wf_J_prog P"
  shows red_type_newthread:
  " P,t  e, s -ta e', s'; P,E,hp s  e : T; NewThread t'' (e'', x'') (hp s')  set tat 
   E T. P,E,hp s'  e'' : T  P,hp s'  x'' (:≤) E"
  and reds_type_newthread:
  " P,t  es, s [-ta→] es', s'; NewThread t'' (e'', x'') (hp s')  set tat; P,E,hp s  es [:] Ts 
   E T. P,E,hp s'  e'' : T  P,hp s'  x'' (:≤) E"
proof(induct arbitrary: E T and E Ts rule: red_reds.inducts)
  case (RedCallExternal s a U M Ts T' D vs ta va h' ta' e' s')
  from ‹NewThread t'' (e'', x'') (hp s')  set ta't ta' = extTA2J P ta
  obtain C' M' a' where nt: "NewThread t'' (C', M', a') (hp s')  set tat"
    and "extNTA2J P (C', M', a') = (e'', x'')" by fastforce
  from red_external_new_thread_sees[OF wf P,t  aM(vs),hp s -ta→ext va,h' nt] typeof_addr (hp s) a = U
  obtain T pns body D where h'a': "typeof_addr h' a' = Class_type C'"
    and sees: " P  C' sees M': []T = (pns, body) in D" by auto
  from sees_wf_mdecl[OF wf sees] obtain T where "P,[this  Class D]  body :: T"
    by(auto simp add: wf_mdecl_def)
  hence "WTrt P (hp s') [this  Class D] body T" by(rule WT_implies_WTrt)
  moreover from sees have "P  C' * D" by(rule sees_method_decl_above)
  with h'a' have "P,h'  [this  Addr a'] (:≤) [this  Class D]" by(auto simp add: lconf_def conf_def)
  ultimately show ?case using h'a' sees s' = (h', lcl s)
    ‹extNTA2J P (C', M', a') = (e'', x'') by(fastforce intro: sees_method_decl_above)
qed(fastforce simp add: ta_upd_simps)+

end

context J_heap_conf_base begin

definition sconf_type_ok :: "(env × ty)  'thread_id  'addr expr × 'addr locals  'heap  bool" 
where
  "sconf_type_ok ET t ex h  fst ET  (h, snd ex)   type_ok P ET (fst ex) h  P,h  t √t"

abbreviation sconf_type_ts_ok ::
  "('thread_id  (env × ty))  ('addr,'thread_id,'addr expr × 'addr locals) thread_info  'heap  bool"
where
  "sconf_type_ts_ok  ts_inv sconf_type_ok"

lemma ts_inv_ok_J_sconf_type_ET_start:
  "ts_inv_ok (thr (J_start_state P C M vs)) (J_sconf_type_ET_start P C M)"
by(rule ts_inv_okI)(simp add: start_state_def J_sconf_type_ET_start_def split_beta)

end

lemma (in J_heap) red_preserve_welltype:
  " extTA,P,t  e, (h, x) -ta e', (h', x'); P,E,h  e'' : T   P,E,h'  e'' : T"
by(auto elim: WTrt_hext_mono dest!: red_hext_incr)

context J_heap_conf begin

lemma sconf_type_ts_ok_J_start_state:
  " wf_J_prog P; wf_start_state P C M vs 
   sconf_type_ts_ok (J_sconf_type_ET_start P C M) (thr (J_start_state P C M vs)) (shr (J_start_state P C M vs))"
apply(erule wf_start_state.cases)
apply(rule ts_invI)
apply(simp add: start_state_def split: if_split_asm)
apply(frule (1) sees_wf_mdecl)
apply(auto simp add: wf_mdecl_def J_sconf_type_ET_start_def sconf_type_ok_def sconf_def type_ok_def)
   apply(erule hconf_start_heap)
  apply(erule preallocated_start_heap)
  apply(erule wf_prog_wf_syscls)
 apply(frule list_all2_lengthD)
 apply(auto simp add: wt_blocks confs_conv_map intro: WT_implies_WTrt)[1]
apply(erule tconf_start_heap_start_tid)
apply(erule wf_prog_wf_syscls)
done

lemma J_start_state_sconf_type_ok:
  assumes wf: "wf_J_prog P"
  and ok: "wf_start_state P C M vs"
  shows "ts_ok (λt x h. ET. sconf_type_ok ET t x h) (thr (J_start_state P C M vs)) start_heap"
using sconf_type_ts_ok_J_start_state[OF assms]
unfolding shr_start_state by(rule ts_inv_into_ts_ok_Ex)

end

context J_conf_read begin

lemma red_preserves_type_ok: 
  " extTA,P,t  e,s -ta e',s'; wf_J_prog P; E  s ; type_ok P (E, T) e (hp s); P,hp s  t √t   type_ok P (E, T) e' (hp s')"
apply(clarsimp simp add: type_ok_def)
apply(subgoal_tac "T''. P,E,hp s'  e' : T''  P  T''  T'")
 apply(fast elim: widen_trans)
by(rule subject_reduction)

lemma lifting_inv_sconf_subject_ok:
  assumes wf: "wf_J_prog P"
  shows "lifting_inv final_expr (mred P) sconf_type_ok"
proof(unfold_locales)
  fix t x m ta x' m' i
  assume mred: "mred P t (x, m) ta (x', m')"
    and "sconf_type_ok i t x m"
  moreover obtain e l where x [simp]: "x = (e, l)" by(cases x, auto)
  moreover obtain e' l' where x' [simp]: "x' = (e', l')" by(cases x', auto)
  moreover obtain E T where i [simp]: "i = (E, T)" by(cases i, auto)
  ultimately have sconf_type: "sconf_type_ok (E, T) t (e, l) m"
    and red: "P,t  e, (m, l) -ta e', (m', l')" by auto
  from sconf_type have sconf: "E  (m, l) " and "type_ok P (E, T) e m" and tconf: "P,m  t √t"
    by(auto simp add: sconf_type_ok_def)
  then obtain T' where "P,E,m  e : T'" "P  T'  T" by(auto simp add: type_ok_def)
  from E  (m, l)  P,E,m  e : T' red tconf
  have "E  (m', l') " by(auto elim: red_preserves_sconf)
  moreover
  from red P,E,m  e : T' wf E  (m, l)  tconf
  obtain T'' where "P,E,m'  e' : T''" "P  T''  T'"
    by(auto dest: subject_reduction)
  note P,E,m'  e' : T''
  moreover
  from P  T''  T' P  T'  T
  have "P  T''  T" by(rule widen_trans)
  moreover from mred tconf have "P,m'  t √t" by(rule red_tconf.preserves_red)  
  ultimately have "sconf_type_ok (E, T) t (e', l') m'"
    by(auto simp add: sconf_type_ok_def type_ok_def)
  thus "sconf_type_ok i t x' m'" by simp
next
  fix t x m ta x' m' i t'' x''
  assume mred: "mred P t (x, m) ta (x', m')"
    and "sconf_type_ok i t x m"
    and "NewThread t'' x'' m'  set tat"
  moreover obtain e l where x [simp]: "x = (e, l)" by(cases x, auto)
  moreover obtain e' l' where x' [simp]: "x' = (e', l')" by(cases x', auto)
  moreover obtain E T where i [simp]: "i = (E, T)" by(cases i, auto)
  moreover obtain e'' l'' where x'' [simp]: "x'' = (e'', l'')" by(cases x'', auto) 
  ultimately have sconf_type: "sconf_type_ok (E, T) t (e, l) m"
    and red: "P,t  e, (m, l) -ta e', (m', l')"
    and nt: "NewThread t'' (e'', l'') m'  set tat" by auto
  from sconf_type have sconf: "E  (m, l) " and "type_ok P (E, T) e m" and tconf: "P,m  t √t"
    by(auto simp add: sconf_type_ok_def)
  then obtain T' where "P,E,m  e : T'" "P  T'  T" by(auto simp add: type_ok_def)
  from nt P,E,m  e : T' red have "E T. P,E,m'  e'' : T  P,m'  l'' (:≤) E"
    by(fastforce dest: red_type_newthread[OF wf])
  then obtain E'' T'' where "P,E'',m'  e'' : T''" "P,m'  l'' (:≤) E''" by blast
  moreover
  from sconf red P,E,m  e : T' tconf have "E  (m', l') "
    by(auto intro: red_preserves_sconf)
  moreover from mred tconf ‹NewThread t'' x'' m'  set tat have "P,m'  t'' √t"
    by(rule red_tconf.preserves_NewThread)
  ultimately show "i''. sconf_type_ok i'' t'' x'' m'"
    by(auto simp add: sconf_type_ok_def type_ok_def sconf_def)
next
  fix t x m ta x' m' i i'' t'' x''
  assume mred: "mred P t (x, m) ta (x', m')" 
    and "sconf_type_ok i t x m" 
    and "sconf_type_ok i'' t'' x'' m" 
  moreover obtain e l where x [simp]: "x = (e, l)" by(cases x, auto)
  moreover obtain e' l' where x' [simp]: "x' = (e', l')" by(cases x', auto)
  moreover obtain E T where i [simp]: "i = (E, T)" by(cases i, auto)
  moreover obtain e'' l'' where x'' [simp]: "x'' = (e'', l'')" by(cases x'', auto)
  moreover obtain E'' T'' where i'' [simp]: "i'' = (E'', T'')" by(cases i'', auto)
  ultimately have sconf_type: "sconf_type_ok (E, T) t (e, l) m"
    and red: "P,t  e, (m, l) -ta e', (m', l')"
    and sc: "sconf_type_ok (E'', T'') t'' (e'', l'') m" by auto
  from sconf_type obtain T' where "P,E,m  e : T'" and "P,m  t √t"
    by(auto simp add: sconf_type_ok_def type_ok_def)
  from sc have sconf: "E''  (m, l'') " and "type_ok P (E'', T'') e'' m" and "P,m  t'' √t"
    by(auto simp add: sconf_type_ok_def)
  then obtain T''' where "P,E'',m  e'' : T'''" "P  T'''  T''" by(auto simp add: type_ok_def)
  moreover from red P,E'',m  e'' : T''' have "P,E'',m'  e'' : T'''"
    by(rule red_preserve_welltype)
  moreover from sconf red P,E,m  e : T' have "hconf m'"
    unfolding sconf_def by(auto dest: red_preserves_hconf)
  moreover {
    from red have "hext m m'" by(auto dest: red_hext_incr)
    moreover from sconf have "P,m  l'' (:≤) E''" "preallocated m"
      by(simp_all add: sconf_def)
    ultimately have "P,m'  l'' (:≤) E''" "preallocated m'"
      by(blast intro: lconf_hext preallocated_hext)+ }
  moreover from mred P,m  t √t P,m  t'' √t
  have "P,m'  t'' √t" by(rule red_tconf.preserves_other)
  ultimately have "sconf_type_ok (E'', T'') t'' (e'', l'') m'"
    by(auto simp add: sconf_type_ok_def sconf_def type_ok_def)
  thus "sconf_type_ok i'' t'' x'' m'" by simp
qed

end

subsection @{term "wf_red"}

context J_progress begin

context begin

declare red_mthr.actions_ok_iff [simp del]
declare red_mthr.actions_ok.cases [rule del]
declare red_mthr.actions_ok.intros [rule del]

lemma assumes wf: "wf_prog wf_md P"
  shows red_wf_red_aux:
  " P,t  e, s -ta e',s'; ¬ red_mthr.actions_ok' (ls, (ts, m), ws, is) t ta; 
    sync_ok e; hconf (hp s); P,hp s  t √t;
     l. has_locks (ls $ l) t  expr_locks e l;
     ws t = None  
     (a vs w T Ts Tr D. call e = (a, wait, vs)  typeof_addr (hp s) a = T  P  class_type_of T sees wait: TsTr = Native in D  ws t = PostWS w) 
     e'' s'' ta'. P,t  e, s -ta' e'',s''  
        (red_mthr.actions_ok (ls, (ts, m), ws, is) t ta'  
         red_mthr.actions_ok' (ls, (ts, m), ws, is) t ta'  red_mthr.actions_subset ta' ta)"
  (is " _; _; _; _; _; _; ?wakeup e s   ?concl e s ta")
    and reds_wf_red_aux:
  " P,t  es, s [-ta→] es',s'; ¬ red_mthr.actions_ok' (ls, (ts, m), ws, is) t ta;
     sync_oks es; hconf (hp s); P,hp s  t √t;
     l. has_locks (ls $ l) t  expr_lockss es l;
     ws t = None  
     (a vs w T Ts T Tr D. calls es = (a, wait, vs)  typeof_addr (hp s) a = T  P  class_type_of T sees wait: TsTr = Native in D  ws t = PostWS w) 
     es'' s'' ta'. P,t  es, s [-ta'→] es'',s''  
        (red_mthr.actions_ok (ls, (ts, m), ws, is) t ta'  
         red_mthr.actions_ok' (ls, (ts, m), ws, is) t ta'  red_mthr.actions_subset ta' ta)"
proof(induct rule: red_reds.inducts)
  case (SynchronizedRed2 e s ta e' s' a)
  note IH = ¬ red_mthr.actions_ok' (ls, (ts, m), ws, is) t ta; sync_ok e; hconf (hp s); P,hp s  t √t;
            l. expr_locks e l  has_locks (ls $ l) t; ?wakeup e s
             ?concl e s ta
  note ¬ red_mthr.actions_ok' (ls, (ts, m), ws, is) t ta
  moreover from ‹sync_ok (insync(a) e) have "sync_ok e" by simp
  moreover note hconf (hp s) P,hp s  t √t
  moreover from l. expr_locks (insync(a) e) l  has_locks (ls $ l) t
  have "l. expr_locks e l  has_locks (ls $ l) t" by(force split: if_split_asm)
  moreover from ?wakeup (insync(a) e) s have "?wakeup e s" by auto
  ultimately have "?concl e s ta" by(rule IH)
  thus ?case by(fastforce intro: red_reds.SynchronizedRed2)
next
  case RedCall thus ?case
    by(auto simp add: is_val_iff contains_insync_conv contains_insyncs_conv red_mthr.actions_ok'_empty red_mthr.actions_ok'_ta_upd_obs dest: sees_method_fun)
next
  case (RedCallExternal s a U M Ts T D vs ta va h' ta' e' s')
  from ?wakeup (addr aM(map Val vs)) s
  have "wset (ls, (ts, m), ws, is) t = None  (M = wait  (w. wset (ls, (ts, m), ws, is) t = PostWS w))" by auto
  with wf  P,t  aM(vs),hp s -ta→ext va, h' P,hp s  t √t hconf (hp s)
  obtain ta'' va' h'' where red': "P,t  aM(vs),hp s -ta''→ext va',h''"
    and aok: "red_mthr.actions_ok (ls, (ts, m), ws, is) t ta'' 
              red_mthr.actions_ok' (ls, (ts, m), ws, is) t ta''  final_thread.actions_subset ta'' ta"
    by(rule red_external_wf_red)
  from aok ta' = extTA2J P ta
  have "red_mthr.actions_ok (ls, (ts, m), ws, is) t (extTA2J P ta'') 
        red_mthr.actions_ok' (ls, (ts, m), ws, is) t (extTA2J P ta'')  red_mthr.actions_subset (extTA2J P ta'') ta'"
    by(auto simp add: red_mthr.actions_ok'_convert_extTA red_mthr.actions_ok_iff elim: final_thread.actions_subset.cases del: subsetI)
  moreover from red' typeof_addr (hp s) a = U P  class_type_of U sees M: TsT = Native in D
  obtain s'' e'' where "P,t  addr aM(map Val vs),s -extTA2J P ta'' e'',s''"
    by(fastforce intro: red_reds.RedCallExternal)
  ultimately show ?case by blast
next
  case LockSynchronized
  hence False by(auto simp add: lock_ok_las'_def finfun_upd_apply ta_upd_simps)
  thus ?case ..
next
  case (UnlockSynchronized a v s)
  from l. expr_locks (insync(a) Val v) l  has_locks (ls $ l) t
  have "has_lock (ls $ a) t" by(force split: if_split_asm)
  with UnlockSynchronized have False by(auto simp add: lock_ok_las'_def finfun_upd_apply ta_upd_simps)
  thus ?case ..
next
  case (SynchronizedThrow2 a ad s)
  from l. expr_locks (insync(a) Throw ad) l  has_locks (ls $ l) t
  have "has_lock (ls $ a) t" by(force split: if_split_asm)
  with SynchronizedThrow2 have False
    by(auto simp add: lock_ok_las'_def finfun_upd_apply ta_upd_simps)
  thus ?case ..
next
  case BlockRed thus ?case by(simp)(blast intro: red_reds.intros)
qed
 (simp_all add: is_val_iff contains_insync_conv contains_insyncs_conv red_mthr.actions_ok'_empty
   red_mthr.actions_ok'_ta_upd_obs thread_action'_to_thread_action.simps red_mthr.actions_ok_iff
  split: if_split_asm del: split_paired_Ex,
  (blast intro: red_reds.intros elim: add_leE)+)

end

end

context J_heap_base begin

lemma shows red_ta_satisfiable:
  "P,t  e, s -ta e', s'  s. red_mthr.actions_ok s t ta"
  and reds_ta_satisfiable:
  "P,t  es, s [-ta→] es', s'  s. red_mthr.actions_ok s t ta"
apply(induct rule: red_reds.inducts)
apply(fastforce simp add: lock_ok_las_def finfun_upd_apply intro: exI[where x="K$ None"] exI[where x="K$ (t, 0)"] may_lock.intros dest: red_external_ta_satisfiable[where final="final_expr :: ('addr expr × 'addr locals)  bool"])+
done

end

context J_typesafe begin

lemma wf_progress: 
  assumes wf: "wf_J_prog P"
  shows "progress final_expr (mred P)
            (red_mthr.wset_Suspend_ok P ({s. sync_es_ok (thr s) (shr s)  lock_ok (locks s) (thr s)}  {s. Es. sconf_type_ts_ok Es (thr s) (shr s)}  {s. def_ass_ts_ok (thr s) (shr s)}))"
  (is "progress _ _ ?wf_state")
proof
  {
    fix s t x ta x' m' w
    assume "mred P t (x, shr s) ta (x', m')"
      and Suspend: "Suspend w  set taw"
    moreover obtain e xs where x: "x = (e, xs)" by(cases x)
    moreover obtain e' xs' where x': "x' = (e', xs')" by(cases x')
    ultimately have red: "P,t  e, (shr s, xs) -ta e', (m', xs')" by simp
    from red_Suspend_is_call[OF red Suspend]
    show "¬ final_expr x'" by(auto simp add: x')
  }
  note Suspend_final = this
  {
    fix s
    assume s: "s  ?wf_state"
    hence "lock_thread_ok (locks s) (thr s)"
      by(auto dest: red_mthr.wset_Suspend_okD1 intro: lock_ok_lock_thread_ok)
    moreover
    have "red_mthr.wset_final_ok (wset s) (thr s)"
    proof(rule red_mthr.wset_final_okI)
      fix t w
      assume "wset s t = w"
      from red_mthr.wset_Suspend_okD2[OF s this]
      obtain x0 ta x m1 w' ln'' and s0 :: "('addr, 'thread_id, 'heap) J_state"
        where mred: "mred P t (x0, shr s0) ta (x, m1)"
        and Suspend: "Suspend w'  set taw" 
        and tst: "thr s t = (x, ln'')" by blast
      from Suspend_final[OF mred Suspend] tst
      show " x ln. thr s t = (x, ln)  ¬ final_expr x" by blast
    qed
    ultimately show "lock_thread_ok (locks s) (thr s)  red_mthr.wset_final_ok (wset s) (thr s)" ..
  }
next
  fix s t ex ta e'x' m'
  assume wfs: "s  ?wf_state"
    and "thr s t = (ex, no_wait_locks)"
    and "mred P t (ex, shr s) ta (e'x', m')"
    and wait: "¬ waiting (wset s t)"
  moreover obtain ls ts m ws "is" where s: "s = (ls, (ts, m), ws, is)" by(cases s) fastforce
  moreover obtain e x where ex: "ex = (e, x)" by(cases ex)
  moreover obtain e' x' where e'x': "e'x' = (e', x')" by(cases e'x')
  ultimately have tst: "ts t = (ex, no_wait_locks)" 
    and red: "P,t  e, (m, x) -ta e', (m', x')" by auto
  from wf have wwf: "wwf_J_prog P" by(rule wf_prog_wwf_prog)
  from wfs s obtain Es where aeos: "sync_es_ok ts m"
    and lockok: "lock_ok ls ts"
    and "sconf_type_ts_ok Es ts m"
    by(auto dest: red_mthr.wset_Suspend_okD1)
  with tst ex obtain E T where sconf: "sconf_type_ok (E, T) t (e, x) m"
    and aoe: "sync_ok e" by(fastforce dest: ts_okD ts_invD)
  then obtain T' where "hconf m" "P,E,m  e : T'" "preallocated m"
    by(auto simp add: sconf_type_ok_def sconf_def type_ok_def)
  from ‹sconf_type_ts_ok Es ts m s have "thread_conf P (thr s) (shr s)"
    by(auto dest: ts_invD intro!: ts_okI simp add: sconf_type_ok_def)
  with ‹thr s t = (ex, no_wait_locks) have "P,shr s  t √t" by(auto dest: ts_okD)

  show "ta' x' m'. mred P t (ex, shr s) ta' (x', m')  
        (red_mthr.actions_ok s t ta'  red_mthr.actions_ok' s t ta'  red_mthr.actions_subset ta' ta)"
  proof(cases "red_mthr.actions_ok' s t ta")
    case True
    have "red_mthr.actions_subset ta ta" ..
    with True ‹mred P t (ex, shr s) ta (e'x', m') show ?thesis by blast
  next
    case False
    from lock_okD2[OF lockok, OF tst[unfolded ex]]
    have locks: "l. has_locks (ls $ l) t  expr_locks e l" by simp
    have "ws t = None  (a vs w T Ts Tr D. call e = (a, wait, vs)  typeof_addr (hp (m, x)) a = T  P  class_type_of T sees wait: TsTr = Native in D  ws t = PostWS w)"
    proof(cases "ws t")
      case None thus ?thesis ..
    next
      case (Some w)
      with red_mthr.wset_Suspend_okD2[OF wfs, of t w] tst ex s
      obtain e0 x0 m0 ta0 w' s1 tta1 
        where red0: "P,t  e0, (m0, x0) -ta0 e, (shr s1, x)"
        and Suspend: "Suspend w'  set ta0w"
        and s1: "P  s1 -▹tta1→* s" by auto 
      from red_Suspend_is_call[OF red0 Suspend] obtain a vs T Ts Tr D
        where call: "call e = (a, wait, vs)"
        and type: "typeof_addr m0 a = T" 
        and iec: "P  class_type_of T sees wait: TsTr = Native in D" by fastforce
      from red0 have "m0  shr s1" by(auto dest: red_hext_incr)
      also from s1 have "shr s1  shr s" by(rule RedT_hext_incr)
      finally have "typeof_addr (shr s) a = T" using type
        by(rule typeof_addr_hext_mono)
      moreover from Some wait s obtain w' where "ws t = PostWS w'"
        by(auto simp add: not_waiting_iff)
      ultimately show ?thesis using call iec s by auto
    qed
    from red_wf_red_aux[OF wf red False[unfolded s] aoe _ _ locks, OF _ _ this] hconf m P,shr s  t √t ex s
    show ?thesis by fastforce
  qed
next
  fix s t x
  assume wfs: "s  ?wf_state"
    and tst: "thr s t = (x, no_wait_locks)" 
    and nfin: "¬ final_expr x"
  obtain e xs where x: "x = (e, xs)" by(cases x)
  from wfs have "def_ass_ts_ok (thr s) (shr s)" by(auto dest: red_mthr.wset_Suspend_okD1)
  with tst x have DA: "𝒟 e dom xs" by(auto dest: ts_okD)
  from wfs obtain Es where "sconf_type_ts_ok Es (thr s) (shr s)"
    by(auto dest: red_mthr.wset_Suspend_okD1)
  with tst x obtain E T where "sconf_type_ok (E, T) t (e, xs) (shr s)" by(auto dest: ts_invD)
  then obtain T' where "hconf (shr s)" "P,E,shr s  e : T'"
    by(auto simp add: sconf_type_ok_def sconf_def type_ok_def)
  from red_progress(1)[OF wf_prog_wwf_prog[OF wf] this DA, where extTA="extTA2J P" and t=t] nfin x
  show "ta x' m'. mred P t (x, shr s) ta (x', m')" by fastforce
next
  fix s t x xm ta xm'
  assume "s  ?wf_state"
    and "thr s t = (x, no_wait_locks)"
    and "mred P t xm ta xm'"
    and "Notified  set taw  WokenUp  set taw"
  thus "collect_waits ta = {}"
    by(auto dest: red_ta_Wakeup_no_Join_no_Lock_no_Interrupt simp: split_beta)
next
  fix s t x ta x' m'
  assume "s  ?wf_state"
    and "thr s t = (x, no_wait_locks)"
    and "mred P t (x, shr s) ta (x', m')"
  thus "s'. red_mthr.actions_ok s' t ta"
    by(fastforce simp add: split_beta dest!: red_ta_satisfiable)
qed

lemma redT_progress_deadlock:
  assumes wf: "wf_J_prog P"
  and wf_start: "wf_start_state P C M vs"
  and Red: "P  J_start_state P C M vs -▹ttas→* s"
  and ndead: "¬ red_mthr.deadlock P s"
  shows "t' ta' s'. P  s -t'ta' s'"
proof -
  let ?wf_state = "red_mthr.wset_Suspend_ok P ({s. sync_es_ok (thr s) (shr s)  lock_ok (locks s) (thr s)}  {s. Es. sconf_type_ts_ok Es (thr s) (shr s)}  {s. def_ass_ts_ok (thr s) (shr s)})"
  interpret red_mthr: progress
    final_expr "mred P" convert_RA ?wf_state
    using wf by(rule wf_progress)
  from wf_start obtain Ts T pns body D 
    where start: "start_heap_ok" "P  C sees M:TsT = (pns, body) in D" "P,start_heap  vs [:≤] Ts"
    by(cases) auto
  from start have len: "length Ts = length vs" by(auto dest: list_all2_lengthD)

  have "invariant3p (mredT P) ?wf_state"
    by(rule red_mthr.invariant3p_wset_Suspend_ok) (intro invariant3p_IntI invariant3p_sync_es_ok_lock_ok[OF wf] lifting_inv.invariant3p_ts_inv[OF lifting_inv_sconf_subject_ok[OF wf]] lifting_wf.invariant3p_ts_ok[OF lifting_wf_def_ass[OF wf]])
  moreover note Red moreover
  have start': "J_start_state P C M vs  ?wf_state"
    apply(rule red_mthr.wset_Suspend_okI)
     apply(blast intro: sconf_type_ts_ok_J_start_state sync_es_ok_J_start_state lock_ok_J_start_state def_ass_ts_ok_J_start_state start wf len len[symmetric] wf_start)
    apply(simp add: start_state_def split_beta)
    done
  ultimately have "s  ?wf_state" unfolding red_mthr.RedT_def
    by(rule invariant3p_rtrancl3p)
  thus ?thesis using ndead by(rule red_mthr.redT_progress)
qed

lemma redT_progress_deadlocked:
  assumes wf: "wf_J_prog P" 
  and wf_start: "wf_start_state P C M vs"
  and Red: "P  J_start_state P C M vs -▹ttas→* s"
  and ndead:  "red_mthr.not_final_thread s t" "¬ t  red_mthr.deadlocked P s"
  shows "t' ta' s'. P  s -t'ta' s'"
using wf wf_start Red
proof(rule redT_progress_deadlock)
  from ndead show "¬ red_mthr.deadlock P s"
    unfolding red_mthr.deadlock_eq_deadlocked'
    by(auto simp add: red_mthr.deadlocked'_def)
qed

subsection ‹Type safety proof›

theorem TypeSafetyT:
  fixes C and M and ttas and Es
  defines "Es  == J_sconf_type_ET_start P C M"
  and     "Es' == upd_invs Es sconf_type_ok (concat (map (thr_a  snd) ttas))"
  assumes wf: "wf_J_prog P"
  and start_wf: "wf_start_state P C M vs"
  and RedT: "P  J_start_state P C M vs -▹ttas→* s'"
  and nored: "¬ (t ta s''. P  s' -tta s'')"
  shows "thread_conf P (thr s') (shr s')"
  and "thr s' t = ((e', x'), ln') 
       (v. e' = Val v  (E T. Es' t = (E, T)  P,shr s'  v :≤ T)  ln' = no_wait_locks)
        (a C. e' = Throw a  typeof_addr (shr s') a = Class_type C  P  C * Throwable  ln' = no_wait_locks)
        (t  red_mthr.deadlocked P s'  (E T. Es' t = (E, T)  (T'. P,E,shr s'  e' : T'  P  T'  T)))"
     (is "_  ?thesis2")
  and "Es m Es'"
proof -
  from start_wf obtain Ts T pns body D
    where start_heap: "start_heap_ok"
    and sees: "P  C sees M:TsT = (pns, body) in D"
    and conf: "P,start_heap  vs [:≤] Ts"
    by cases auto

  from RedT show "thread_conf P (thr s') (shr s')"
    by(rule red_tconf.RedT_preserves)(rule thread_conf_start_state[OF start_heap wf_prog_wf_syscls[OF wf]])

  show "Es m Es'" using RedT ts_inv_ok_J_sconf_type_ET_start
    unfolding Es'_def Es_def by(rule red_mthr.RedT_upd_inv_ext)

  assume "thr s' t = ((e', x'), ln')"
  moreover obtain ls' ts' m' ws' is' where s' [simp]: "s' = (ls', (ts', m'), ws', is')" by(cases s') fastforce
  ultimately have es't: "ts' t = ((e', x'), ln')" by simp
  from wf have wwf: "wwf_J_prog P" by(rule wf_prog_wwf_prog)
  from conf have len: "length vs = length Ts" by(rule list_all2_lengthD)
  from RedT def_ass_ts_ok_J_start_state[OF wf sees len] have defass': "def_ass_ts_ok ts' m'"
    by(fastforce dest: lifting_wf.RedT_preserves[OF lifting_wf_def_ass, OF wf])
  from RedT sync_es_ok_J_start_state[OF wf sees len[symmetric]] lock_ok_J_start_state[OF wf sees len[symmetric]]
  have lock': "lock_ok ls' ts'" by (fastforce dest: RedT_preserves_lock_ok[OF wf])
  from RedT sync_es_ok_J_start_state[OF wf sees len[symmetric]] have addr': "sync_es_ok ts' m'"
    by(fastforce dest: RedT_preserves_sync_ok[OF wf])
  from RedT sconf_type_ts_ok_J_start_state[OF wf start_wf]
  have sconf_subject': "sconf_type_ts_ok Es' ts' m'" unfolding Es'_def Es_def
    by(fastforce dest: lifting_inv.RedT_invariant[OF lifting_inv_sconf_subject_ok, OF wf] intro: thread_conf_start_state[OF _ wf_prog_wf_syscls[OF wf]])
  with es't obtain E T where ET: "Es' t = (E, T)" 
    and "sconf_type_ok (E, T) t (e', x') m'" by(auto dest!: ts_invD)
  { assume "final e'"
    have "ln' = no_wait_locks"
    proof(rule ccontr)
      assume "ln'  no_wait_locks"
      then obtain l where "ln' $ l > 0"
        by(auto simp add: neq_no_wait_locks_conv)
      from lock' es't have "has_locks (ls' $ l) t + ln' $ l = expr_locks e' l"
        by(auto dest: lock_okD2)
      with ln' $ l > 0 have "expr_locks e' l > 0" by simp
      moreover from ‹final e' have "expr_locks e' l = 0" by(rule final_locks)
      ultimately show False by simp
    qed }
  note ln' = this
  { assume "v. e' = Val v"
    then obtain v where v: "e' = Val v" by blast
    with sconf_subject' ET es't have "P,m'  v :≤ T"
      by(auto dest: ts_invD simp add: type_ok_def sconf_type_ok_def conf_def)
    moreover from v ln' have "ln' = no_wait_locks" by(auto)
    ultimately have "v. e' = Val v  (E T. Es' t = (E, T)  P,m'  v :≤ T  ln' = no_wait_locks)"
      using ET v by blast }
  moreover
  { assume "a. e' = Throw a"
    then obtain a where a: "e' = Throw a" by blast
    with sconf_subject' ET es't have "T'. P,E,m'  e' : T'  P  T'  T"
      apply -
      apply(drule ts_invD, assumption)
      by(clarsimp simp add: type_ok_def sconf_type_ok_def)
    then obtain T' where "P,E,m'  e' : T'" and "P  T'  T" by blast
    with a have "C. typeof_addr m' a = Class_type C  P  C * Throwable"
      by(auto simp add: widen_Class)
    moreover from a ln' have "ln' = no_wait_locks" by(auto)
    ultimately have "a C. e' = Throw a  typeof_addr m' a = Class_type C  P  C * Throwable  ln' = no_wait_locks"
      using a by blast }
  moreover
  { assume nfine': "¬ final e'"
    with es't have "red_mthr.not_final_thread s' t"
      by(auto intro: red_mthr.not_final_thread.intros)
    with nored have "t  red_mthr.deadlocked P s'"
      by -(erule contrapos_np, rule redT_progress_deadlocked[OF wf start_wf RedT])
    moreover 
    from ‹sconf_type_ok (E, T) t (e', x') m'
    obtain T'' where "P,E,m'  e' : T''" "P  T''  T"
      by(auto simp add: sconf_type_ok_def type_ok_def)
    with ET have "E T. Es' t = (E, T)  (T'. P,E,m'  e' : T'  P  T'  T)"
      by blast
    ultimately have "t  red_mthr.deadlocked P s'  (E T. Es' t = (E, T)  (T'. P,E,m'  e' : T'  P  T'  T))" .. }
  ultimately show ?thesis2 by simp(blast)
qed

end

end

Theory Deadlocked

(*  Title:      JinjaThreads/J/Deadlocked.thy
    Author:     Andreas Lochbihler
*)

section ‹Preservation of Deadlock›

theory Deadlocked
imports
  ProgressThreaded
begin

context J_progress begin

lemma red_wt_hconf_hext:
  assumes wf: "wf_J_prog P"
  and hconf: "hconf H"
  and tconf: "P,H  t √t"
  shows " convert_extTA extNTA,P,t  e, s -ta e', s'; P,E,H  e : T; hext H (hp s) 
         ta' e' s'. convert_extTA extNTA,P,t  e, (H, lcl s) -ta' e', s' 
                       collect_locks tal = collect_locks ta'l  collect_cond_actions tac = collect_cond_actions ta'c 
                       collect_interrupts tai = collect_interrupts ta'i"
  and " convert_extTA extNTA,P,t  es, s [-ta→] es', s'; P,E,H  es [:] Ts; hext H (hp s) 
         ta' es' s'. convert_extTA extNTA,P,t  es, (H, lcl s) [-ta'→] es', s'  
                        collect_locks tal = collect_locks ta'l  collect_cond_actions tac = collect_cond_actions ta'c 
                        collect_interrupts tai = collect_interrupts ta'i"
proof(induct arbitrary: E T and E Ts rule: red_reds.inducts)
  case (RedNew h' a h C l)
  thus ?case
    by(cases "allocate H (Class_type C) = {}")(fastforce simp add: ta_upd_simps intro: RedNewFail red_reds.RedNew)+
next
  case (RedNewFail h C l)
  thus ?case
    by(cases "allocate H (Class_type C) = {}")(fastforce simp add: ta_upd_simps intro: red_reds.RedNewFail RedNew)+
next 
  case NewArrayRed thus ?case by(fastforce intro: red_reds.intros)
next
  case (RedNewArray i h' a h T l E T')
  thus ?case
    by(cases "allocate H (Array_type T (nat (sint i))) = {}")(fastforce simp add: ta_upd_simps intro: red_reds.RedNewArray RedNewArrayFail)+
next
  case RedNewArrayNegative thus ?case by(fastforce intro: red_reds.intros)
next
  case (RedNewArrayFail i h T l E T')
  thus ?case 
    by(cases "allocate H (Array_type T (nat (sint i))) = {}")(fastforce simp add: ta_upd_simps intro: RedNewArray red_reds.RedNewArrayFail)+
next
  case CastRed thus ?case by(fastforce intro: red_reds.intros)
next
  case (RedCast s v U T E T')
  from P,E,H  Cast T (Val v) : T' show ?case
  proof(rule WTrt_elim_cases)
    fix T''
    assume wt: "P,E,H  Val v : T''" "T' = T"
    thus ?thesis
      by(cases "P  T''  T")(fastforce intro: red_reds.RedCast red_reds.RedCastFail)+
  qed
next 
  case (RedCastFail s v U T E T')
  from P,E,H  Cast T (Val v) : T' 
  obtain T'' where "P,E,H  Val v : T''" "T = T'" by auto
  thus ?case
    by(cases "P  T''  T")(fastforce intro: red_reds.RedCast red_reds.RedCastFail)+
next
  case InstanceOfRed thus ?case by(fastforce intro: red_reds.intros)
next
  case RedInstanceOf thus ?case
    using [[hypsubst_thin = true]] 
    by auto((rule exI conjI red_reds.RedInstanceOf)+, auto)
next
  case BinOpRed1 thus ?case by(fastforce intro: red_reds.intros)
next
  case BinOpRed2 thus ?case by(fastforce intro: red_reds.intros)
next
  case RedBinOp thus ?case by(fastforce intro: red_reds.intros)
next
  case RedBinOpFail thus ?case by(fastforce intro: red_reds.intros)
next
  case RedVar thus ?case by(fastforce intro: red_reds.intros)
next
  case LAssRed thus ?case by(fastforce intro: red_reds.intros)
next
  case RedLAss thus ?case by(fastforce intro: red_reds.intros)
next
  case AAccRed1 thus ?case by(fastforce intro: red_reds.intros)
next
  case AAccRed2 thus ?case by(fastforce intro: red_reds.intros)
next
  case RedAAccNull thus ?case by(fastforce intro: red_reds.intros)
next
  case RedAAccBounds thus ?case
    by(fastforce intro: red_reds.RedAAccBounds dest: hext_arrD)
next 
  case (RedAAcc h a T n i v l E T')
  from P,E,H  addr aVal (Intg i) : T' 
  have wt: "P,E,H  addr a : T'⌊⌉" by(auto)
  with H  hp (h, l) typeof_addr h a = Array_type T n
  have Ha: "typeof_addr H a = Array_type T n" by(auto dest: hext_arrD)
  with 0 <=s i ‹sint i < int n
  have "nat (sint i) < n"
    by (simp add: word_sle_eq nat_less_iff)
  with Ha have "P,H  a@ACell (nat (sint i)) : T"
    by(auto intro: addr_loc_type.intros)
  from heap_read_total[OF hconf this]
  obtain v where "heap_read H a (ACell (nat (sint i))) v" by blast
  with Ha 0 <=s i ‹sint i < int n show ?case
    by(fastforce intro: red_reds.RedAAcc simp add: ta_upd_simps)
next
  case AAssRed1 thus ?case by(fastforce intro: red_reds.intros)
next
  case AAssRed2 thus ?case by(fastforce intro: red_reds.intros)
next
  case AAssRed3 thus ?case by(fastforce intro: red_reds.intros)
next
  case RedAAssNull thus ?case by(fastforce intro: red_reds.intros)
next
  case RedAAssBounds thus ?case by(fastforce intro: red_reds.RedAAssBounds dest: hext_arrD)
next
  case (RedAAssStore s a T n i w U E T')
  from P,E,H  addr aVal (Intg i) := Val w : T' 
  obtain T'' T''' where wt: "P,E,H  addr a : T''⌊⌉"
    and wtw: "P,E,H  Val w : T'''" by auto
  with H  hp s typeof_addr (hp s) a = Array_type T n
  have Ha: "typeof_addr H a = Array_type T n" by(auto dest: hext_arrD)
  from ‹typeofhp s w = U wtw H  hp s have "typeofH w = U" 
    by(auto dest: type_of_hext_type_of)
  with Ha 0 <=s i ‹sint i < int n ¬ P  U  T show ?case
    by(fastforce intro: red_reds.RedAAssStore)
next
  case (RedAAss h a T n i w U h' l E T')
  from P,E,H  addr aVal (Intg i) := Val w : T'
  obtain T'' T''' where wt: "P,E,H  addr a : T''⌊⌉"
      and wtw: "P,E,H  Val w : T'''" by auto
  with H  hp (h, l) typeof_addr h a = Array_type T n
  have Ha: "typeof_addr H a = Array_type T n" by(auto dest: hext_arrD)
  from ‹typeofh w = U wtw H  hp (h, l) have "typeofH w = U" 
    by(auto dest: type_of_hext_type_of)
  moreover
  with P  U  T have conf: "P,H  w :≤ T"
    by(auto simp add: conf_def)
  from 0 <=s i ‹sint i < int n
  have "nat (sint i) < n"
    by (simp add: word_sle_eq nat_less_iff)
  with Ha have "P,H  a@ACell (nat (sint i)) : T"
    by(auto intro: addr_loc_type.intros)
  from heap_write_total[OF hconf this conf]
  obtain H' where "heap_write H a (ACell (nat (sint i))) w H'" ..
  ultimately show ?case using 0 <=s i ‹sint i < int n Ha P  U  T
    by(fastforce simp del: split_paired_Ex intro: red_reds.RedAAss)
next
  case ALengthRed thus ?case by(fastforce intro: red_reds.intros)
next
  case (RedALength h a T n l E T')
  from P,E,H  addr a∙length : T'
  obtain T'' where [simp]: "T' = Integer"
      and wta: "P,E,H  addr a : T''⌊⌉" by(auto)
  then obtain n'' where "typeof_addr H a = Array_type T'' n''" by(auto)
  thus ?case by(fastforce intro: red_reds.RedALength)
next
  case RedALengthNull show ?case by(fastforce intro: red_reds.RedALengthNull)
next
  case FAccRed thus ?case by(fastforce intro: red_reds.intros)
next
  case (RedFAcc h a D F v l E T)
  from P,E,H  addr aF{D} : T obtain U C' fm
    where wt: "P,E,H  addr a : U"
    and icto: "class_type_of' U = C'"
    and has: "P  C' has F:T (fm) in D"
    by(auto)
  then obtain hU where Ha: "typeof_addr H a = hU" "U = ty_of_htype hU" by(auto)
  with icto P  C' has F:T (fm) in D have "P,H  a@CField D F : T"
    by(auto intro: addr_loc_type.intros)
  from heap_read_total[OF hconf this]
  obtain v where "heap_read H a (CField D F) v" by blast
  thus ?case by(fastforce intro: red_reds.RedFAcc simp add: ta_upd_simps)
next
  case RedFAccNull thus ?case by(fastforce intro: red_reds.intros)
next
  case FAssRed1 thus ?case by(fastforce intro: red_reds.intros)
next
  case FAssRed2 thus ?case by(fastforce intro: red_reds.intros)
next
  case RedFAssNull thus ?case by(fastforce intro: red_reds.intros)
next
  case (RedFAss h a D F v h' l E T)
  from P,E,H  addr aF{D} := Val v : T obtain U C' T' T2 fm
    where wt: "P,E,H  addr a : U"
    and icto: "class_type_of' U = C'"
    and has: "P  C' has F:T' (fm) in D"
    and wtv: "P,E,H  Val v : T2"
    and T2T: "P  T2  T'" by(auto)
  moreover from wt obtain hU where Ha: "typeof_addr H a = hU" "U = ty_of_htype hU" by(auto)
  with icto has have adal: "P,H  a@CField D F : T'" by(auto intro: addr_loc_type.intros)
  from wtv T2T have "P,H  v :≤ T'" by(auto simp add: conf_def)
  from heap_write_total[OF hconf adal this]
  obtain h' where "heap_write H a (CField D F) v h'" ..
  thus ?case by(fastforce intro: red_reds.RedFAss)
next
  case CASRed1 thus ?case by(fastforce intro: red_reds.intros)
next
  case CASRed2 thus ?case by(fastforce intro: red_reds.intros)
next
  case CASRed3 thus ?case by(fastforce intro: red_reds.intros)
next
  case CASNull thus ?case by(fastforce intro: red_reds.intros)
next
  case (RedCASSucceed h a D F v v' h' l)
  note split_paired_Ex[simp del]
  from RedCASSucceed.prems(1) obtain T' fm T2 T3 U C where *:
    "T = Boolean" "class_type_of' U = C" "P  C has F:T' (fm) in D" 
    "volatile fm" "P  T2  T'" "P  T3  T'"
    "P,E,H  Val v : T2" "P,E,H  Val v' : T3" "P,E,H  addr a : U" by auto
  then have adal: "P,H  a@CField D F : T'" by(auto intro: addr_loc_type.intros)
  from heap_read_total[OF hconf this] obtain v'' where v': "heap_read H a (CField D F) v''" by blast
  show ?case
  proof(cases "v'' = v")
    case True
    from * have "P,H  v' :≤ T'" by(auto simp add: conf_def)
    from heap_write_total[OF hconf adal this] True * v'
    show ?thesis by(fastforce intro: red_reds.RedCASSucceed)
  next
    case False
    then show ?thesis using * v' by(fastforce intro: RedCASFail)
  qed
next
  case (RedCASFail h a D F v'' v v' l)
  note split_paired_Ex[simp del]
  from RedCASFail.prems(1) obtain T' fm T2 T3 U C where *:
    "T = Boolean" "class_type_of' U = C" "P  C has F:T' (fm) in D" 
    "volatile fm" "P  T2  T'" "P  T3  T'"
    "P,E,H  Val v : T2" "P,E,H  Val v' : T3" "P,E,H  addr a : U" by auto
  then have adal: "P,H  a@CField D F : T'" by(auto intro: addr_loc_type.intros)
  from heap_read_total[OF hconf this] obtain v''' where v'': "heap_read H a (CField D F) v'''" by blast
  show ?case
  proof(cases "v''' = v")
    case True
    from * have "P,H  v' :≤ T'" by(auto simp add: conf_def)
    from heap_write_total[OF hconf adal this] True * v''
    show ?thesis by(fastforce intro: red_reds.RedCASSucceed)
  next
    case False
    then show ?thesis using * v'' by(fastforce intro: red_reds.RedCASFail)
  qed
next
  case CallObj thus ?case by(fastforce intro: red_reds.intros)
next
  case CallParams thus ?case by(fastforce intro: red_reds.intros)
next
  case (RedCall s a U M Ts T pns body D vs E T')
  from P,E,H  addr aM(map Val vs) : T' 
  obtain U' C' Ts' meth D' Ts''
    where wta: "P,E,H  addr a : U'"
    and icto: "class_type_of' U' = C'"
    and sees: "P  C' sees M: Ts'T' = meth in D'"
    and wtes: "P,E,H  map Val vs [:] Ts''"
    and widens: "P  Ts'' [≤] Ts'" by auto
  from wta obtain hU' where Ha: "typeof_addr H a = hU'" "U' = ty_of_htype hU'" by(auto)
  moreover from typeof_addr (hp s) a = U H  hp s Ha
  have [simp]: "U = hU'" by(auto dest: typeof_addr_hext_mono)
  from wtes have "length vs = length Ts''"
    by(auto intro: map_eq_imp_length_eq)
  moreover from widens have "length Ts'' = length Ts'"
    by(auto dest: widens_lengthD)
  moreover from sees icto sees P  class_type_of U sees M: TsT = (pns, body) in D Ha
  have [simp]: "meth = (pns, body)" by(auto dest: sees_method_fun)
  with sees wf have "wf_mdecl wf_J_mdecl P D' (M, Ts', T', (pns, body))"
    by(auto intro: sees_wf_mdecl)
  hence "length pns = length Ts'" by(simp add: wf_mdecl_def)
  ultimately show ?case using sees icto 
    by(fastforce intro: red_reds.RedCall)
next
  case (RedCallExternal s a U M Ts T' D vs ta va h' ta' e' s')
  from P,E,H  addr aM(map Val vs) : T 
  obtain U' C' Ts' meth D' Ts'' 
    where wta: "P,E,H  addr a : U'" and icto: "class_type_of' U' = C'"
    and sees: "P  C' sees M: Ts'T = meth in D'"
    and wtvs: "P,E,H  map Val vs [:] Ts''" 
    and sub: "P  Ts'' [≤] Ts'" by auto
  from wta typeof_addr (hp s) a = U ‹hext H (hp s) have [simp]: "U' = ty_of_htype U"
    by(auto dest: typeof_addr_hext_mono)
  with icto have [simp]: "C' = class_type_of U" by(auto)
  from sees P  class_type_of U sees M: TsT' = Native in D
  have [simp]: "meth = Native" by(auto dest: sees_method_fun)
  with wta sees icto wtvs sub have "P,H  aM(vs) : T"
    by(cases U)(auto 4 4 simp add: external_WT'_iff)
  from red_external_wt_hconf_hext[OF wf P,t  aM(vs),hp s -ta→ext va,h' H  hp s this tconf hconf]
    wta icto sees ta' = convert_extTA extNTA ta e' = extRet2J (addr aM(map Val vs)) va s' = (h', lcl s)
  show ?case by(cases U)(auto 4 5 intro: red_reds.RedCallExternal simp del: split_paired_Ex)
next
  case RedCallNull thus ?case by(fastforce intro: red_reds.intros)
next
  case (BlockRed e h l V vo ta e' h' l' T E T')
  note IH = BlockRed.hyps(2)
  from IH[of "E(V  T)" T'] P,E,H  {V:T=vo; e} : T' ‹hext H (hp (h, l))
  show ?case by(fastforce dest: red_reds.BlockRed)
next
  case RedBlock thus ?case by(fastforce intro: red_reds.intros)
next
  case SynchronizedRed1 thus ?case by(fastforce intro: red_reds.intros)
next
  case SynchronizedNull thus ?case by(fastforce intro: red_reds.intros)
next
  case LockSynchronized thus ?case by(fastforce intro: red_reds.intros)
next
  case SynchronizedRed2 thus ?case by(fastforce intro: red_reds.intros)
next
  case UnlockSynchronized thus ?case by(fastforce intro: red_reds.intros)
next
  case SeqRed thus ?case by(fastforce intro: red_reds.intros)
next
  case RedSeq thus ?case by(fastforce intro: red_reds.intros)
next
  case CondRed thus ?case by(fastforce intro: red_reds.intros)
next
  case RedCondT thus ?case by(fastforce intro: red_reds.intros)
next
  case RedCondF thus ?case by(fastforce intro: red_reds.intros)
next
  case RedWhile thus ?case by(fastforce intro: red_reds.intros)
next
  case ThrowRed thus ?case by(fastforce intro: red_reds.intros)
next
  case RedThrowNull thus ?case by(fastforce intro: red_reds.intros)
next
  case TryRed thus ?case by(fastforce intro: red_reds.intros)
next
  case RedTry thus ?case by(fastforce intro: red_reds.intros)
next
  case (RedTryCatch s a D C V e2 E T)
  from P,E,H  try Throw a catch(C V) e2 : T
  obtain T' where "P,E,H  addr a : T'" by auto
  with typeof_addr (hp s) a = Class_type D ‹hext H (hp s)
  have Ha: "typeof_addr H a = Class_type D"
    by(auto dest: typeof_addr_hext_mono)
  with P  D * C show ?case
    by(fastforce intro: red_reds.RedTryCatch)
next
  case (RedTryFail s a D C V e2 E T)
  from P,E,H  try Throw a catch(C V) e2 : T
  obtain T' where "P,E,H  addr a : T'" by auto
  with typeof_addr (hp s) a = Class_type D ‹hext H (hp s)
  have Ha: "typeof_addr H a = Class_type D" 
    by(auto dest: typeof_addr_hext_mono)
  with ¬ P  D * C show ?case
    by(fastforce intro: red_reds.RedTryFail)
next
  case ListRed1 thus ?case by(fastforce intro: red_reds.intros)
next
  case ListRed2 thus ?case by(fastforce intro: red_reds.intros)
next
  case NewArrayThrow thus ?case by(fastforce intro: red_reds.intros)
next
  case CastThrow thus ?case by(fastforce intro: red_reds.intros)
next
  case InstanceOfThrow thus ?case by(fastforce intro: red_reds.intros)
next
  case BinOpThrow1 thus ?case by(fastforce intro: red_reds.intros)
next
  case BinOpThrow2 thus ?case by(fastforce intro: red_reds.intros)
next
  case LAssThrow thus ?case by(fastforce intro: red_reds.intros)
next
  case AAccThrow1 thus ?case by(fastforce intro: red_reds.intros)
next
  case AAccThrow2 thus ?case by(fastforce intro: red_reds.intros)
next
  case AAssThrow1 thus ?case by(fastforce intro: red_reds.intros)
next
  case AAssThrow2 thus ?case by(fastforce intro: red_reds.intros)
next
  case AAssThrow3 thus ?case by(fastforce intro: red_reds.intros)
next
  case ALengthThrow thus ?case by(fastforce intro: red_reds.intros)
next
  case FAccThrow thus ?case by(fastforce intro: red_reds.intros)
next
  case FAssThrow1 thus ?case by(fastforce intro: red_reds.intros)
next 
  case FAssThrow2 thus ?case by(fastforce intro: red_reds.intros)
next
  case CASThrow thus ?case by(fastforce intro: red_reds.intros)
next
  case CASThrow2 thus ?case by(fastforce intro: red_reds.intros)
next
  case CASThrow3 thus ?case by(fastforce intro: red_reds.intros)
next
  case CallThrowObj thus ?case by(fastforce intro: red_reds.intros)
next
  case CallThrowParams thus ?case by(fastforce intro: red_reds.intros)
next
  case BlockThrow thus ?case by(fastforce intro: red_reds.intros)
next
  case SynchronizedThrow1 thus ?case by(fastforce intro: red_reds.intros)
next
  case SynchronizedThrow2 thus ?case by(fastforce intro: red_reds.intros)
next
  case SeqThrow thus ?case by(fastforce intro: red_reds.intros)
next
  case CondThrow thus ?case by(fastforce intro: red_reds.intros)
next
  case ThrowThrow thus ?case by(fastforce intro: red_reds.intros)
qed

lemma can_lock_devreserp:
  " wf_J_prog P; red_mthr.can_sync P t (e, l) h' L; P,E,h  e : T; P,h  t √t; hconf h; h  h'  
   red_mthr.can_sync P t (e, l) h L"
apply(erule red_mthr.can_syncE)
apply(clarsimp)
apply(drule red_wt_hconf_hext, assumption+)
 apply(simp)
apply(fastforce intro!: red_mthr.can_syncI)
done

end

context J_typesafe begin

lemma preserve_deadlocked:
  assumes wf: "wf_J_prog P"
  shows "preserve_deadlocked final_expr (mred P) convert_RA ({s. sync_es_ok (thr s) (shr s)  lock_ok (locks s) (thr s)}  {s. Es. sconf_type_ts_ok Es (thr s) (shr s)}  {s. def_ass_ts_ok (thr s) (shr s)})"
  (is "preserve_deadlocked _ _ _ ?wf_state")
proof(unfold_locales)
  show inv: "invariant3p (mredT P) ?wf_state"
    by(intro invariant3p_IntI invariant3p_sync_es_ok_lock_ok[OF wf] lifting_inv.invariant3p_ts_inv[OF lifting_inv_sconf_subject_ok[OF wf]] lifting_wf.invariant3p_ts_ok[OF lifting_wf_def_ass[OF wf]])
  
  fix s t' ta' s' t x ln
  assume wfs: "s  ?wf_state" 
    and redT: "P  s -t'ta' s'"
    and tst: "thr s t = (x, ln)" 
  from redT have hext: "shr s  shr s'" by(rule redT_hext_incr)
  
  from inv redT wfs have wfs': "s'  ?wf_state" by(rule invariant3pD)
  from redT tst obtain x' ln' where ts't: "thr s' t= (x', ln')"
    by(cases "thr s' t")(cases s, cases s', auto dest: red_mthr.redT_thread_not_disappear)

  from wfs tst obtain E T where wt: "P,E,shr s  fst x : T" 
    and hconf: "hconf (shr s)"
    and da: "𝒟 (fst x) dom (snd x)"
    and tconf: "P,shr s  t √t"
    by(force dest: ts_invD ts_okD simp add: type_ok_def sconf_def sconf_type_ok_def)
  from wt hext have wt': "P,E,shr s'  fst x : T" by(rule WTrt_hext_mono)
  from wfs' ts't have hconf': "hconf (shr s')" 
    by(auto dest: ts_invD simp add: type_ok_def sconf_def sconf_type_ok_def)

  {
    assume cs: "red_mthr.must_sync P t x (shr s)"
    from cs have "¬ final (fst x)" by(auto elim!: red_mthr.must_syncE simp add: split_beta)

    from progress[OF wf_prog_wwf_prog[OF wf] hconf' wt' da this, of "extTA2J P" t]
    obtain e' h x' ta where "P,t  fst x,(shr s', snd x) -ta e', (h, x')" by auto
    with red_ta_satisfiable[OF this]
    show "red_mthr.must_sync P t x (shr s')"
      by-(rule red_mthr.must_syncI, fastforce simp add: split_beta)
  next
    fix LT
    assume "red_mthr.can_sync P t x (shr s') LT"
    with can_lock_devreserp[OF wf _ wt tconf hconf hext, of "snd x" LT]
    show "LT'LT. red_mthr.can_sync P t x (shr s) LT'" by auto
  }
qed

end

end

Theory Annotate

(*  Title:      Jinja/J/Annotate.thy
    Author:     Tobias Nipkow, Andreas Lochbihler
*)

section ‹Program annotation›

theory Annotate
imports
  WellType
begin

abbreviation (output)
  unanFAcc :: "'addr expr  vname  'addr expr" ("(__)" [10,10] 90)
where
  "unanFAcc e F  FAcc e F (STR '''')"

abbreviation (output)
  unanFAss :: "'addr expr  vname  'addr expr  'addr expr" ("(__ := _)" [10,0,90] 90)
where
  "unanFAss e F e'  FAss e F (STR '''') e'"

definition array_length_field_name :: vname
where "array_length_field_name = STR ''length''"

notation (output) array_length_field_name ("length")

definition super :: vname
where "super = STR ''super''"

lemma super_neq_this [simp]: "super  this" "this  super"
by(simp_all add: this_def super_def)

inductive Anno :: "(ty  ty  ty  bool)  'addr J_prog  env  'addr expr  'addr expr  bool" 
  ("_,_,_  _  _"   [51,51,0,0,51]50)
  and Annos :: "(ty  ty  ty  bool)  'addr J_prog  env  'addr expr list  'addr expr list  bool"
  ("_,_,_  _ [↝] _" [51,51,0,0,51]50)
for is_lub :: "ty  ty  ty  bool" and P :: "'addr J_prog"
where
  AnnoNew: "is_lub,P,E  new C  new C"
| AnnoNewArray: "is_lub,P,E  i  i'  is_lub,P,E  newA Ti  newA Ti'"
| AnnoCast: "is_lub,P,E  e  e'  is_lub,P,E  Cast C e  Cast C e'"
| AnnoInstanceOf: "is_lub,P,E  e  e'  is_lub,P,E  e instanceof T  e' instanceof T"
| AnnoVal: "is_lub,P,E  Val v  Val v"
| AnnoVarVar: " E V = T; V  super   is_lub,P,E  Var V  Var V"
| AnnoVarField:
  ― ‹There is no need to handle access of array fields explicitly,
    because arrays do not implement methods, i.e. @{term "this"} is
    always of a @{term "Class"} type.›
  " E V = None; V  super; E this = Class C; P  C sees V:T (fm) in D 
   is_lub,P,E  Var V  Var thisV{D}"
| AnnoBinOp:
  " is_lub,P,E  e1  e1';  is_lub,P,E  e2  e2' 
    is_lub,P,E  e1 «bop» e2  e1' «bop» e2'"
| AnnoLAssVar:
  " E V = T; V  super; is_lub,P,E  e  e'   is_lub,P,E  V:=e  V:=e'"
| AnnoLAssField:
  " E V = None; V  super; E this = Class C; P  C sees V:T (fm) in D; is_lub,P,E  e  e' 
    is_lub,P,E  V:=e  Var thisV{D} := e'"
| AnnoAAcc:
  " is_lub,P,E  a  a'; is_lub,P,E  i  i'   is_lub,P,E  ai  a'i'"
| AnnoAAss:
  " is_lub,P,E  a  a'; is_lub,P,E  i  i'; is_lub,P,E  e  e'   is_lub,P,E  ai := e  a'i' := e'"
| AnnoALength:
  "is_lub,P,E  a  a'  is_lub,P,E  a∙length  a'∙length"
| ― ‹All arrays implicitly declare a final field called @{term "array_length_field_name"} to
    store the array length, which hides a potential field of the same name in @{term "Object"} (cf. JLS 6.4.5).
    The last premise implements the hiding because field lookup does does not model the implicit declaration.›
  AnnoFAcc:
  " is_lub,P,E  e  e';  is_lub,P,E  e' :: U; class_type_of' U = C; P  C sees F:T (fm) in D; 
     is_Array U  F  array_length_field_name 
    is_lub,P,E  eF{STR ''''}  e'F{D}"
| AnnoFAccALength:
  " is_lub,P,E  e  e'; is_lub,P,E  e' :: T⌊⌉ 
   is_lub,P,E  earray_length_field_name{STR ''''}  e'∙length"
| AnnoFAccSuper:
  ― ‹In class C with super class D, "super" is syntactic sugar for "((D) this)" (cf. JLS, 15.11.2)›
  " E this = Class C; C  Object; class P C = (D, fs, ms); 
     P  D sees F:T (fm) in D' 
   is_lub,P,E  Var superF{STR ''''}  (Cast (Class D) (Var this))F{D'}"
|  AnnoFAss:
  " is_lub,P,E  e1  e1';  is_lub,P,E  e2  e2';
     is_lub,P,E  e1' :: U; class_type_of' U = C; P  C sees F:T (fm) in D;
     is_Array U  F  array_length_field_name 
   is_lub,P,E  e1F{STR ''''} := e2  e1'F{D} := e2'"
| AnnoFAssSuper:
  " E this = Class C; C  Object; class P C = (D, fs, ms);
     P  D sees F:T (fm) in D'; is_lub,P,E  e  e' 
   is_lub,P,E  Var superF{STR ''''} := e  (Cast (Class D) (Var this))F{D'} := e'"
| AnnoCAS:
  " is_lub,P,E  e1  e1'; is_lub,P,E  e2  e2'; is_lub,P,E  e3  e3' 
   is_lub,P,E  e1∙compareAndSwap(DF, e2, e3)  e1'∙compareAndSwap(DF, e2', e3')"
| AnnoCall:
  " is_lub,P,E  e  e';  is_lub,P,E  es [↝] es' 
    is_lub,P,E  Call e M es  Call e' M es'"
| AnnoBlock:
  "is_lub,P,E(V  T)  e  e'    is_lub,P,E  {V:T=vo; e}  {V:T=vo; e'}"
| AnnoSync:
  " is_lub,P,E  e1  e1'; is_lub,P,E  e2  e2' 
   is_lub,P,E  sync(e1) e2  sync(e1') e2'"
| AnnoComp:
  " is_lub,P,E  e1  e1';  is_lub,P,E  e2  e2' 
    is_lub,P,E  e1;;e2  e1';;e2'"
| AnnoCond:
  " is_lub,P,E  e  e'; is_lub,P,E  e1  e1';  is_lub,P,E  e2  e2' 
    is_lub,P,E  if (e) e1 else e2  if (e') e1' else e2'"
| AnnoLoop:
  " is_lub,P,E  e  e';  is_lub,P,E  c  c' 
   is_lub,P,E  while (e) c  while (e') c'"
| AnnoThrow:
  "is_lub,P,E  e  e'  is_lub,P,E  throw e  throw e'"
| AnnoTry:
  " is_lub,P,E  e1  e1';  is_lub,P,E(V  Class C)  e2  e2' 
    is_lub,P,E  try e1 catch(C V) e2  try e1' catch(C V) e2'"

| AnnoNil:
  "is_lub,P,E  [] [↝] []"
| AnnoCons:
  " is_lub,P,E  e  e';  is_lub,P,E  es [↝] es'    is_lub,P,E  e#es [↝] e'#es'"

inductive_cases Anno_cases [elim!]:
  "is_lub',P,E  new C  e"
  "is_lub',P,E  newA Te  e'"
  "is_lub',P,E  Cast T e  e'"
  "is_lub',P,E  e instanceof T  e'"
  "is_lub',P,E  Val v  e'"
  "is_lub',P,E  Var V  e'"
  "is_lub',P,E  e1 «bop» e2  e'"
  "is_lub',P,E  V := e  e'"
  "is_lub',P,E  e1e2  e'"
  "is_lub',P,E  e1e2 := e3  e'"
  "is_lub',P,E  e∙length  e'"
  "is_lub',P,E  eF{D}  e'"
  "is_lub',P,E  e1F{D} := e2  e'"
  "is_lub',P,E  e1∙compareAndSwap(DF, e2, e3)  e'"
  "is_lub',P,E  eM(es)  e'"
  "is_lub',P,E  {V:T=vo; e}  e'"
  "is_lub',P,E  sync(e1) e2  e'"
  "is_lub',P,E  insync(a) e2  e'"
  "is_lub',P,E  e1;; e2  e'"
  "is_lub',P,E  if (e) e1 else e2  e'"
  "is_lub',P,E  while(e1) e2  e'"
  "is_lub',P,E  throw e  e'"
  "is_lub',P,E  try e1 catch(C V) e2  e'"

inductive_cases Annos_cases [elim!]:
  "is_lub',P,E  [] [↝] es'"
  "is_lub',P,E  e # es [↝] es'"

abbreviation Anno' :: "'addr J_prog  env  'addr expr  'addr expr  bool"  ("_,_  _  _"   [51,0,0,51]50)
where "Anno' P  Anno (TypeRel.is_lub P) P"

abbreviation Annos' :: "'addr J_prog  env  'addr expr list  'addr expr list  bool"  ("_,_  _ [↝] _" [51,0,0,51]50)
where "Annos' P  Annos (TypeRel.is_lub P) P"

definition annotate :: "'addr J_prog  env  'addr expr  'addr expr"
where "annotate P E e = THE_default e (λe'. P,E  e  e')"

lemma fixes is_lub :: "ty  ty  ty  bool" (" lub'((_,/ _)') = _" [51,51,51] 50)
  assumes is_lub_unique: "T1 T2 T3 T4.   lub(T1, T2) = T3;  lub(T1, T2) = T4   T3 = T4"
  shows Anno_fun: " is_lub,P,E  e  e'; is_lub,P,E  e  e''   e' = e''"
  and Annos_fun: " is_lub,P,E  es [↝] es'; is_lub,P,E  es [↝] es''   es' = es''"
proof(induct arbitrary: e'' and es'' rule: Anno_Annos.inducts)
  case (AnnoFAcc E e e' U C F T fm D)
  from is_lub,P,E  eF{STR ''''}  e'' show ?case
  proof(rule Anno_cases)
    fix e''' U' C' T' fm' D'
    assume "is_lub,P,E  e  e'''" "is_lub,P,E  e''' :: U'"
      and "class_type_of' U' = C'"
      and "P  C' sees F:T' (fm') in D'" "e'' = e'''F{D'}"
    from is_lub,P,E  e  e''' have "e' = e'''" by(rule AnnoFAcc)
    with is_lub,P,E  e' :: U is_lub,P,E  e''' :: U'
    have "U = U'" by(auto intro: WT_unique is_lub_unique)
    with ‹class_type_of' U = C ‹class_type_of' U' = C'
    have "C = C'" by(auto)
    with P  C' sees F:T' (fm') in D' P  C sees F:T (fm) in D
    have "D' = D" by(auto dest: sees_field_fun)
    with e'' = e'''F{D'} e' = e''' show ?thesis by simp
  next
    fix e''' T
    assume "e'' = e'''∙length"
      and "is_lub,P,E  e''' :: T⌊⌉"
      and "is_lub,P,E  e  e'''"
      and "F = array_length_field_name"
    from is_lub,P,E  e  e''' have "e' = e'''" by(rule AnnoFAcc)
    with is_lub,P,E  e' :: U is_lub,P,E  e''' :: T⌊⌉ have "U = T⌊⌉" by(auto intro: WT_unique is_lub_unique)
    with ‹class_type_of' U = C ‹is_Array U  F  array_length_field_name›
    show ?thesis using F = array_length_field_name› by simp
  next
    fix C' D' fs ms T D''
    assume "E this = Class C'"
      and "class P C' = (D', fs, ms)"
      and "e = Var super"
      and "e'' = Cast (Class D') (Var this)F{D''}"
    with is_lub,P,E  e  e' have False by(auto)
    thus ?thesis ..
  qed
next
  case AnnoFAccALength thus ?case by(fastforce intro: WT_unique[OF is_lub_unique])
next
  case (AnnoFAss E e1 e1' e2 e2' U C F T fm D)
  from is_lub,P,E  e1F{STR ''''} := e2  e'' 
  show ?case
  proof(rule Anno_cases)
    fix e1'' e2'' U' C' T' fm' D'
    assume "is_lub,P,E  e1  e1''" "is_lub,P,E  e2  e2''"
      and "is_lub,P,E  e1'' :: U'" and "class_type_of' U' = C'"
      and "P  C' sees F:T' (fm') in D'"
      and "e'' = e1''F{D'} := e2''"
    from is_lub,P,E  e1  e1'' have "e1' = e1''" by(rule AnnoFAss)
    moreover with is_lub,P,E  e1' :: U is_lub,P,E  e1'' :: U'
    have "U = U'" by(auto intro: WT_unique is_lub_unique)
    with ‹class_type_of' U = C ‹class_type_of' U' = C'
    have "C = C'" by(auto)
    with P  C' sees F:T' (fm') in D' P  C sees F:T (fm) in D
    have "D' = D" by(auto dest: sees_field_fun)
    moreover from is_lub,P,E  e2  e2'' have "e2' = e2''" by(rule AnnoFAss)
    ultimately show ?thesis using e'' = e1''F{D'} := e2'' by simp
  next
    fix C' D' fs ms T' fm' D'' e'''
    assume "e'' = Cast (Class D') (Var this)F{D''} := e'''"
      and "E this = Class C'"
      and "class P C' = (D', fs, ms)"
      and "P  D' sees F:T' (fm') in D''"
      and "is_lub,P,E  e2  e'''"
      and "e1 = Var super"
    with is_lub,P,E  e1  e1' have False by(auto elim: Anno_cases)
    thus ?thesis ..
  qed
qed(fastforce dest: sees_field_fun)+

subsection ‹Code generation›

definition Anno_code :: "'addr J_prog  env  'addr expr  'addr expr  bool" ("_,_  _ ↝'' _"   [51,0,0,51]50)
where "Anno_code P = Anno (is_lub_sup P) P"

definition Annos_code :: "'addr J_prog  env  'addr expr list  'addr expr list  bool" ("_,_  _ [↝''] _" [51,0,0,51]50)
where "Annos_code P = Annos (is_lub_sup P) P"

primrec block_types :: "('a, 'b, 'addr) exp  ty list" 
  and blocks_types :: "('a, 'b, 'addr) exp list  ty list"
where 
  "block_types (new C) = []"
| "block_types (newA Te) = block_types e"
| "block_types (Cast U e) = block_types e"
| "block_types (e instanceof U) = block_types e"
| "block_types (e1«bop»e2) = block_types e1 @ block_types e2"
| "block_types (Val v) = []"
| "block_types (Var V) = []"
| "block_types (V := e) = block_types e"
| "block_types (ai) = block_types a @ block_types i"
| "block_types (ai := e) = block_types a @ block_types i @ block_types e"
| "block_types (a∙length) = block_types a"
| "block_types (eF{D}) = block_types e"
| "block_types (eF{D} := e') = block_types e @ block_types e'"
| "block_types (e∙compareAndSwap(DF, e', e'')) = block_types e @ block_types e' @ block_types e''"
| "block_types (eM(es)) = block_types e @ blocks_types es"
| "block_types {V:T=vo; e} = T # block_types e"
| "block_types (syncV(e) e') = block_types e @ block_types e'"
| "block_types (insyncV(a) e) = block_types e"
| "block_types (e;;e') = block_types e @ block_types e'"
| "block_types (if (e) e1 else e2) = block_types e @ block_types e1 @ block_types e2"
| "block_types (while (b) c) = block_types b @ block_types c"
| "block_types (throw e) = block_types e"
| "block_types (try e catch(C V) e') = block_types e @ Class C # block_types e'"

| "blocks_types [] = []"
| "blocks_types (e#es) = block_types e @ blocks_types es"

lemma fixes is_lub1 :: "ty  ty  ty  bool" ("⊢1 lub'((_,/ _)') = _" [51,51,51] 50)
  and is_lub2 :: "ty  ty  ty  bool" ("⊢2 lub'((_,/ _)') = _" [51,51,51] 50)
  assumes wf: "wf_prog wf_md P"
  and is_lub1_into_is_lub2: "T1 T2 T3.  ⊢1 lub(T1, T2) = T3; is_type P T1; is_type P T2   ⊢2 lub(T1, T2) = T3"
  and is_lub2_is_type: "T1 T2 T3.  ⊢2 lub(T1, T2) = T3; is_type P T1; is_type P T2   is_type P T3"
  shows Anno_change_is_lub:
  " is_lub1,P,E  e  e'; ran E  set (block_types e)  types P   is_lub2,P,E  e  e'"
  and Annos_change_is_lub:
  " is_lub1,P,E  es [↝] es'; ran E  set (blocks_types es)  types P   is_lub2,P,E  es [↝] es'"
proof(induct rule: Anno_Annos.inducts)
  case (AnnoBlock E V T e e' vo)
  from ‹ran E  set (block_types {V:T=vo; e})  types P
  have "ran (E(V  T))  set (block_types e)  types P"
    by(auto simp add: ran_def)
  thus ?case using AnnoBlock by(blast intro: Anno_Annos.intros)
next
  case (AnnoTry E e1 e1' V C e2 e2')
  from ‹ran E  set (block_types (try e1 catch(C V) e2))  types P
  have "ran (E(V  Class C))  set (block_types e2)  types P"
    by(auto simp add: ran_def)
  thus ?case using AnnoTry by(simp del: fun_upd_apply)(blast intro: Anno_Annos.intros)
qed(simp_all del: is_Array.simps is_Array_conv, (blast intro: Anno_Annos.intros WT_change_is_lub[OF wf, where ?is_lub1.0=is_lub1 and ?is_lub2.0=is_lub2] is_lub1_into_is_lub2 is_lub2_is_type)+)

lemma assumes wf: "wf_prog wf_md P"
  shows Anno_into_Anno_code: " P,E  e  e'; ran E  set (block_types e)  types P   P,E  e ↝' e'"
  and Annos_into_Annos_code: " P,E  es [↝] es'; ran E  set (blocks_types es)  types P   P,E  es [↝'] es'"
proof -
  assume anno: "P,E  e  e'" 
    and ran: "ran E  set (block_types e)  types P"
  show "P,E  e ↝' e'" unfolding Anno_code_def
    by(rule Anno_change_is_lub[OF wf _ _ anno ran])(blast intro!: is_lub_sup.intros intro: is_lub_subD[OF wf] sup_is_type[OF wf] elim!: is_lub_sup.cases)+ 
next
  assume annos: "P,E  es [↝] es'"
    and ran: "ran E  set (blocks_types es)  types P"
  show "P,E  es [↝'] es'" unfolding Annos_code_def
    by(rule Annos_change_is_lub[OF wf _ _ annos ran])(blast intro!: is_lub_sup.intros intro: is_lub_subD[OF wf] sup_is_type[OF wf] elim!: is_lub_sup.cases)+
qed 

lemma assumes wf: "wf_prog wf_md P"
  shows Anno_code_into_Anno: " P,E  e ↝' e'; ran E  set (block_types e)  types P   P,E  e  e'"
  and Annos_code_into_Annos: " P,E  es [↝'] es'; ran E  set (blocks_types es)  types P   P,E  es [↝] es'"
proof -
  assume anno: "P,E  e ↝' e'" 
    and ran: "ran E  set (block_types e)  types P"
  show "P,E  e  e'"
    by(rule Anno_change_is_lub[OF wf _ _ anno[unfolded Anno_code_def] ran])(blast elim!: is_lub_sup.cases intro: sup_is_lubI[OF wf] is_lub_is_type[OF wf])+
next
  assume annos: "P,E  es [↝'] es'"
    and ran: "ran E  set (blocks_types es)  types P"
  show "P,E  es [↝] es'"
    by(rule Annos_change_is_lub[OF wf _ _ annos[unfolded Annos_code_def] ran])(blast elim!: is_lub_sup.cases intro: sup_is_lubI[OF wf] is_lub_is_type[OF wf])+
qed

lemma fixes is_lub
  assumes wf: "wf_prog wf_md P"
  shows WT_block_types_is_type: "is_lub,P,E  e :: T  set (block_types e)  types P"
  and WTs_blocks_types_is_type: "is_lub,P,E  es [::] Ts  set (blocks_types es)  types P"
apply(induct rule: WT_WTs.inducts)
apply(auto intro: is_class_sub_Throwable[OF wf])
done

lemma fixes is_lub
  shows Anno_block_types: "is_lub,P,E  e  e'  block_types e = block_types e'"
  and Annos_blocks_types: "is_lub,P,E  es [↝] es'  blocks_types es = blocks_types es'"
by(induct rule: Anno_Annos.inducts) auto

code_pred 
  (modes: (i ⇒ i ⇒ o ⇒ bool) ⇒ i ⇒ i ⇒ i ⇒ o ⇒ bool)
  [detect_switches, skip_proof]
  Anno
.

definition annotate_code :: "'addr J_prog  env  'addr expr  'addr expr"
where "annotate_code P E e = THE_default e (λe'. P,E  e ↝' e')"

code_pred
  (modes: i ⇒ i ⇒ i ⇒ o ⇒ bool)
  [inductify]
  Anno_code 
.

lemma eval_Anno_i_i_i_o_conv:
  "Predicate.eval (Anno_code_i_i_i_o P E e) = (λe'. P,E  e ↝' e')"
by(auto intro!: ext intro: Anno_code_i_i_i_oI elim: Anno_code_i_i_i_oE)
 
lemma annotate_code [code]:
  "annotate_code P E e = Predicate.singleton (λ_. Code.abort (STR ''annotate'') (λ_. e)) (Anno_code_i_i_i_o P E e)"
by(simp add: THE_default_def Predicate.singleton_def annotate_code_def eval_Anno_i_i_i_o_conv)

end

Theory J_Main

theory J_Main
imports
  State
  Deadlocked
  Annotate
begin

end

Theory JVMState

(*  Title:      JinjaThreads/JVM/JVMState.thy
    Author:     Cornelia Pusch, Gerwin Klein, Andreas Lochbihler
*)

chapter ‹Jinja Virtual Machine \label{cha:jvm}›

section ‹State of the JVM›

theory JVMState
imports
  "../Common/Observable_Events"
begin

subsection ‹Frame Stack›

type_synonym 
  pc = nat

type_synonym
  'addr frame = "'addr val list × 'addr val list × cname × mname × pc"
  ― ‹operand stack› 
  ― ‹registers (including this pointer, method parameters, and local variables)›
  ― ‹name of class where current method is defined›
  ― ‹parameter types›
  ― ‹program counter within frame›

(* pretty printing for frame type *)
print_translation let
    fun tr'
       [Const (@{type_syntax "list"}, _) $ (Const (@{type_syntax "val"}, _) $ a1),
        Const (@{type_syntax "prod"}, _) $
          (Const (@{type_syntax "list"}, _) $ (Const (@{type_syntax "val"}, _) $ a2)) $
          (Const (@{type_syntax "prod"}, _) $
             Const (@{type_syntax "String.literal"}, _) $
             (Const (@{type_syntax "prod"}, _) $
                Const (@{type_syntax "String.literal"}, _) $
                Const (@{type_syntax "nat"}, _)))] =
      if a1 = a2 then Syntax.const @{type_syntax "frame"} $ a1
      else raise Match;
    in [(@{type_syntax "prod"}, K tr')]
  end
typ "'addr frame"

subsection ‹Runtime State›
type_synonym
  ('addr, 'heap) jvm_state = "'addr option × 'heap × 'addr frame list"  
  ― ‹exception flag, heap, frames›

type_synonym
  'addr jvm_thread_state = "'addr option × 'addr frame list"
  ― ‹exception flag, frames, thread lock state›

type_synonym
  ('addr, 'thread_id, 'heap) jvm_thread_action = "('addr, 'thread_id, 'addr jvm_thread_state,'heap) Jinja_thread_action"

type_synonym
  ('addr, 'thread_id, 'heap) jvm_ta_state = "('addr, 'thread_id, 'heap) jvm_thread_action × ('addr, 'heap) jvm_state"

(* pretty printing for jvm_thread_action type *)
print_translation let
    fun tr'
       [a1, t
       , Const (@{type_syntax "prod"}, _) $ 
           (Const (@{type_syntax "option"}, _) $ a2) $
           (Const (@{type_syntax "list"}, _) $ 
             (Const (@{type_syntax "prod"}, _) $
               (Const (@{type_syntax "list"}, _) $ (Const (@{type_syntax "val"}, _) $ a3)) $
               (* Next bit: same syntax translation as for frame *)
               (Const (@{type_syntax "prod"}, _) $
                 (Const (@{type_syntax "list"}, _) $ (Const (@{type_syntax "val"}, _) $ a4)) $
                 (Const (@{type_syntax "prod"}, _) $
                   Const (@{type_syntax "String.literal"}, _) $
                   (Const (@{type_syntax "prod"}, _) $
                      Const (@{type_syntax "String.literal"}, _) $
                      Const (@{type_syntax "nat"}, _))))))
       , h] =
      if a1 = a2 andalso a2 = a3 andalso a3 = a4 then Syntax.const @{type_syntax "jvm_thread_action"} $ a1 $ t $ h
      else raise Match;
    in [(@{type_syntax "Jinja_thread_action"}, K tr')]
  end
typ "('addr, 'thread_id, 'heap) jvm_thread_action"

end

Theory JVMInstructions

(*  Title:      JinjaThreads/JVM/JVMInstructions.thy
    Author:     Gerwin Klein, Andreas Lochbihler
*)

section ‹Instructions of the JVM›

theory JVMInstructions
imports
  JVMState
  "../Common/BinOp"
begin

datatype 'addr instr 
  = Load nat                  ― ‹load from local variable›
  | Store nat                 ― ‹store into local variable›
  | Push "'addr val"          ― ‹push a value (constant)›
  | New cname                 ― ‹create object›
  | NewArray ty               ― ‹create array for elements of given type›
  | ALoad                     ― ‹Load array element from heap to stack›
  | AStore                    ― ‹Set element in array›
  | ALength                   ― ‹Return the length of the array›
  | Getfield vname cname      ― ‹Fetch field from object›
  | Putfield vname cname      ― ‹Set field in object›
  | CAS vname cname           ― ‹Compare-and-swap instruction›
  | Checkcast ty              ― ‹Check whether object is of given type›
  | Instanceof ty             ― ‹instanceof test›
  | Invoke mname nat          ― ‹inv. instance meth of an object›
  | Return                    ― ‹return from method›
  | Pop                       ― ‹pop top element from opstack›
  | Dup                       ― ‹duplicate top stack element›
  | Swap                      ― ‹swap top stack elements›
  | BinOpInstr bop            ― ‹binary operator instruction›
  | Goto int                  ― ‹goto relative address›
  | IfFalse int               ― ‹branch if top of stack false›
  | ThrowExc                  ― ‹throw top of stack as exception›
  | MEnter                    ― ‹enter the monitor of object on top of the stack›
  | MExit                     ― ‹exit the monitor of object on top of the stack›

abbreviation CmpEq :: "'addr instr"
where "CmpEq  BinOpInstr Eq"

abbreviation CmpLeq :: "'addr instr"
where "CmpLeq  BinOpInstr LessOrEqual"

abbreviation CmpGeq :: "'addr instr"
where "CmpGeq  BinOpInstr GreaterOrEqual"

abbreviation CmpLt :: "'addr instr"
where "CmpLt  BinOpInstr LessThan"

abbreviation CmpGt :: "'addr instr"
where "CmpGt  BinOpInstr GreaterThan"

abbreviation IAdd :: "'addr instr"
where "IAdd  BinOpInstr Add"

abbreviation ISub :: "'addr instr"
where "ISub  BinOpInstr Subtract"

abbreviation IMult :: "'addr instr"
where "IMult  BinOpInstr Mult"

abbreviation IDiv :: "'addr instr"
where "IDiv  BinOpInstr Div"

abbreviation IMod :: "'addr instr"
where "IMod  BinOpInstr Mod"

abbreviation IShl :: "'addr instr"
where "IShl  BinOpInstr ShiftLeft"

abbreviation IShr :: "'addr instr"
where "IShr  BinOpInstr ShiftRightSigned"

abbreviation IUShr :: "'addr instr"
where "IUShr  BinOpInstr ShiftRightZeros"

abbreviation IAnd :: "'addr instr"
where "IAnd  BinOpInstr BinAnd"

abbreviation IOr :: "'addr instr"
where "IOr  BinOpInstr BinOr"

abbreviation IXor :: "'addr instr"
where "IXor  BinOpInstr BinXor"

type_synonym
  'addr bytecode = "'addr instr list"

type_synonym
  ex_entry = "pc × pc × cname option × pc × nat" 
  ― ‹start-pc, end-pc, exception type (None = Any), handler-pc, remaining stack depth›

type_synonym
  ex_table = "ex_entry list"

type_synonym
  'addr jvm_method = "nat × nat × 'addr bytecode × ex_table"
   ― ‹max stacksize›
   ― ‹number of local variables. Add 1 + no. of parameters to get no. of registers›
   ― ‹instruction sequence›
   ― ‹exception handler table›

type_synonym
  'addr jvm_prog = "'addr jvm_method prog" 

end

Theory JVMHeap

(*  Title:      JinjaThreads/JVM/JVMHeap.thy
    Author:     Andreas Lochbihler
*)

section ‹Abstract heap locales for byte code programs›

theory JVMHeap
imports
  "../Common/Conform"
  JVMInstructions
begin

locale JVM_heap_base =
  heap_base +
  constrains addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"

locale JVM_heap =
  JVM_heap_base +
  heap +
  constrains addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and P :: "'addr jvm_prog"

locale JVM_heap_conf_base =
  heap_conf_base +
  constrains addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and hconf :: "'heap  bool"
  and P :: "'addr jvm_prog"

sublocale JVM_heap_conf_base < JVM_heap_base .

locale JVM_heap_conf_base' =
  JVM_heap_conf_base +
  heap +
  constrains addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and hconf :: "'heap  bool"
  and P :: "'addr jvm_prog"

sublocale JVM_heap_conf_base' < JVM_heap by(unfold_locales)

locale JVM_heap_conf = 
  JVM_heap_conf_base' +
  heap_conf +
  constrains addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and hconf :: "'heap  bool"
  and P :: "'addr jvm_prog"

locale JVM_progress =
  heap_progress +
  JVM_heap_conf_base' +
  constrains addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and hconf :: "'heap  bool"
  and P :: "'addr jvm_prog"

locale JVM_conf_read =
  heap_conf_read +
  JVM_heap_conf +
  constrains addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and hconf :: "'heap  bool"
  and P :: "'addr jvm_prog"

locale JVM_typesafe =
  heap_typesafe +
  JVM_conf_read +
  JVM_progress +
  constrains addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and hconf :: "'heap  bool"
  and P :: "'addr jvm_prog"

end

Theory JVMExecInstr

(*  Title:      JinjaThreads/JVM/JVMExecInstr.thy
    Author:     Cornelia Pusch, Gerwin Klein, Andreas Lochbihler
*)

section ‹JVM Instruction Semantics›

theory JVMExecInstr
imports
  JVMInstructions
  JVMHeap
  "../Common/ExternalCall"
begin

primrec extRet2JVM :: 
  "nat  'heap  'addr val list  'addr val list  cname  mname  pc  'addr frame list 
   'addr extCallRet  ('addr, 'heap) jvm_state"
where
  "extRet2JVM n h stk loc C M pc frs (RetVal v) = (None, h, (v # drop (Suc n) stk, loc, C, M, pc + 1) # frs)"
| "extRet2JVM n h stk loc C M pc frs (RetExc a) = (a, h, (stk, loc, C, M, pc) # frs)"
| "extRet2JVM n h stk loc C M pc frs RetStaySame = (None, h, (stk, loc, C, M, pc) # frs)"

lemma eq_extRet2JVM_conv [simp]:
  "(xcp, h', frs') = extRet2JVM n h stk loc C M pc frs va  
   h' = h  (case va of RetVal v  xcp = None  frs' = (v # drop (Suc n) stk, loc, C, M, pc + 1) # frs
                      | RetExc a  xcp = a  frs' = (stk, loc, C, M, pc) # frs
                      | RetStaySame  xcp = None  frs' = (stk, loc, C, M, pc) # frs)"
by(cases va) auto

definition extNTA2JVM :: "'addr jvm_prog  (cname × mname × 'addr)  'addr jvm_thread_state"
where "extNTA2JVM P  (λ(C, M, a). let (D,M',Ts,meth) = method P C M; (mxs,mxl0,ins,xt) = the meth
                                   in (None, [([],Addr a # replicate mxl0 undefined_value, D, M, 0)]))"

abbreviation extTA2JVM :: 
  "'addr jvm_prog  ('addr, 'thread_id, 'heap) external_thread_action  ('addr, 'thread_id, 'heap) jvm_thread_action"
where "extTA2JVM P  convert_extTA (extNTA2JVM P)"

context JVM_heap_base begin

primrec exec_instr ::
  "'addr instr  'addr jvm_prog  'thread_id  'heap  'addr val list  'addr val list
   cname  mname  pc  'addr frame list 
    (('addr, 'thread_id, 'heap) jvm_thread_action × ('addr, 'heap) jvm_state) set"
where
exec_instr_Load:
 "exec_instr (Load n) P t h stk loc C0 M0 pc frs = 
      {(ε, (None, h, ((loc ! n) # stk, loc, C0, M0, pc+1)#frs))}"

| "exec_instr (Store n) P t h stk loc C0 M0 pc frs = 
      {(ε, (None, h, (tl stk, loc[n:=hd stk], C0, M0, pc+1)#frs))}"

| exec_instr_Push:
 "exec_instr (Push v) P t h stk loc C0 M0 pc frs = 
      {(ε, (None, h, (v # stk, loc, C0, M0, pc+1)#frs))}"

| exec_instr_New:
 "exec_instr (New C) P t h stk loc C0 M0 pc frs = 
  (let HA = allocate h (Class_type C)
   in if HA = {} then {(ε, addr_of_sys_xcpt OutOfMemory, h, (stk, loc, C0, M0, pc) # frs)}
      else (λ(h', a). (NewHeapElem a (Class_type C), None, h', (Addr a # stk, loc, C0, M0, pc + 1)#frs)) ` HA)"

| exec_instr_NewArray:
  "exec_instr (NewArray T) P t h stk loc C0 M0 pc frs =
  (let si = the_Intg (hd stk);
       i = nat (sint si)
   in (if si <s 0
       then {(ε, addr_of_sys_xcpt NegativeArraySize, h, (stk, loc, C0, M0, pc) # frs)}
        else let HA = allocate h (Array_type T i)
             in if HA = {} then {(ε, addr_of_sys_xcpt OutOfMemory, h, (stk, loc, C0, M0, pc) # frs)}
                else (λ(h', a). (NewHeapElem a (Array_type T i), None, h', (Addr a # tl stk, loc, C0, M0, pc + 1) # frs)) ` HA))"

| exec_instr_ALoad:
  "exec_instr ALoad P t h stk loc C0 M0 pc frs =
   (let i = the_Intg (hd stk);
        va = hd (tl stk);
        a = the_Addr va;
        len = alen_of_htype (the (typeof_addr h a))
    in (if va = Null then {(ε, addr_of_sys_xcpt NullPointer, h, (stk, loc, C0, M0, pc) # frs)}
        else if i <s 0  int len  sint i then
             {(ε, addr_of_sys_xcpt ArrayIndexOutOfBounds, h, (stk, loc, C0, M0, pc) # frs)}
        else {(ReadMem a (ACell (nat (sint i))) v, None, h, (v # tl (tl stk), loc, C0, M0, pc + 1) # frs) | v. 
              heap_read h a (ACell (nat (sint i))) v }))"

| exec_instr_AStore:
  "exec_instr AStore P t h stk loc C0 M0 pc frs =
  (let ve = hd stk;
       vi = hd (tl stk);
       va = hd (tl (tl stk))
   in (if va = Null then {(ε, addr_of_sys_xcpt NullPointer, h, (stk, loc, C0, M0, pc) # frs)}
       else (let i = the_Intg vi;
                 idx = nat (sint i);
                 a = the_Addr va;
                 hT = the (typeof_addr h a);
                 T = ty_of_htype hT;
                 len = alen_of_htype hT;
                 U = the (typeofh ve)
             in (if i <s 0  int len  sint i then
                      {(ε, addr_of_sys_xcpt ArrayIndexOutOfBounds, h, (stk, loc, C0, M0, pc) # frs)}
                 else if P  U  the_Array T then 
                      {(WriteMem a (ACell idx) ve, None, h', (tl (tl (tl stk)), loc, C0, M0, pc+1) # frs)
                       | h'. heap_write h a (ACell idx) ve h'}
                 else {(ε, (addr_of_sys_xcpt ArrayStore, h, (stk, loc, C0, M0, pc) # frs))}))))"

| exec_instr_ALength:
  "exec_instr ALength P t h stk loc C0 M0 pc frs =
   {(ε, (let va = hd stk
         in if va = Null
            then (addr_of_sys_xcpt NullPointer, h, (stk, loc, C0, M0, pc) # frs)
            else (None, h, (Intg (word_of_int (int (alen_of_htype (the (typeof_addr h (the_Addr va)))))) # tl stk, loc, C0, M0, pc+1) # frs)))}"

| "exec_instr (Getfield F C) P t h stk loc C0 M0 pc frs = 
   (let v = hd stk
    in if v = Null then {(ε, addr_of_sys_xcpt NullPointer, h, (stk, loc, C0, M0, pc) # frs)}
       else let a = the_Addr v
            in {(ReadMem a (CField C F) v', None, h, (v' # (tl stk), loc, C0, M0, pc + 1) # frs) | v'.
                heap_read h a (CField C F) v'})"

| "exec_instr (Putfield F C) P t h stk loc C0 M0 pc frs = 
  (let v = hd stk;
       r = hd (tl stk)
   in if r = Null then {(ε, addr_of_sys_xcpt NullPointer, h, (stk, loc, C0, M0, pc) # frs)}
      else let a = the_Addr r
           in {(WriteMem a (CField C F) v, None, h', (tl (tl stk), loc, C0, M0, pc + 1) # frs) | h'.
               heap_write h a (CField C F) v h'})"

| "exec_instr (CAS F C) P t h stk loc C0 M0 pc frs =
  (let v'' = hd stk; v' = hd (tl stk); v = hd (tl (tl stk))
   in if v = Null then {(ε, addr_of_sys_xcpt NullPointer, h, (stk, loc, C0, M0, pc) # frs)}
      else let a = the_Addr v
           in {(ReadMem a (CField C F) v', WriteMem a (CField C F) v'', None, h', (Bool True # tl (tl (tl stk)), loc, C0, M0, pc + 1) # frs) | h' .
                heap_read h a (CField C F) v'  heap_write h a (CField C F) v'' h'} 
              {(ReadMem a (CField C F) v'', None, h, (Bool False # tl (tl (tl stk)), loc, C0, M0, pc + 1) # frs) | v''.
                heap_read h a (CField C F) v''  v''  v'})"

| "exec_instr (Checkcast T) P t h stk loc C0 M0 pc frs =
  {(ε, let U = the (typeofh (hd stk))
       in if P  U  T then (None, h, (stk, loc, C0, M0, pc + 1) # frs)
          else (addr_of_sys_xcpt ClassCast, h, (stk, loc, C0, M0, pc) # frs))}"

| "exec_instr (Instanceof T) P t h stk loc C0 M0 pc frs =
  {(ε, None, h, (Bool (hd stk  Null  P  the (typeofh (hd stk))  T) # tl stk, loc, C0, M0, pc + 1) # frs)}"

| exec_instr_Invoke:
 "exec_instr (Invoke M n) P t h stk loc C0 M0 pc frs =
  (let ps = rev (take n stk);
       r = stk ! n;
       a = the_Addr r;
       T = the (typeof_addr h a)
   in (if r = Null then {(ε, addr_of_sys_xcpt NullPointer, h, (stk, loc, C0, M0, pc) # frs)}
       else 
         let C = class_type_of T;
             (D,M',Ts,meth)= method P C M
         in case meth of 
               Native 
               {(extTA2JVM P ta, extRet2JVM n h' stk loc C0 M0 pc frs va) | ta va h'.
                (ta, va, h')  red_external_aggr P t a M ps h}
            | (mxs,mxl0,ins,xt) 
              let f' = ([],[r]@ps@(replicate mxl0 undefined_value),D,M,0)
              in {(ε, None, h, f' # (stk, loc, C0, M0, pc) # frs)}))"

| "exec_instr Return P t h stk0 loc0 C0 M0 pc frs =
  {(ε, (if frs=[] then (None, h, []) else 
       let v = hd stk0; 
           (stk,loc,C,m,pc) = hd frs;
           n = length (fst (snd (method P C0 M0)))
       in (None, h, (v#(drop (n+1) stk),loc,C,m,pc+1)#tl frs)) )}"

| "exec_instr Pop P t h stk loc C0 M0 pc frs = 
      {(ε, (None, h, (tl stk, loc, C0, M0, pc+1)#frs) )}"

| "exec_instr Dup P t h stk loc C0 M0 pc frs = 
      {(ε, (None, h, (hd stk # stk, loc, C0, M0, pc+1)#frs) )}"

| "exec_instr Swap P t h stk loc C0 M0 pc frs = 
      {(ε, (None, h, (hd (tl stk) # hd stk # tl (tl stk), loc, C0, M0, pc+1)#frs) )}"

| "exec_instr (BinOpInstr bop) P t h stk loc C0 M0 pc frs =
  {(ε, 
   case the (binop bop (hd (tl stk)) (hd stk)) of
     Inl v  (None, h, (v # tl (tl stk), loc, C0, M0, pc+1) # frs)
   | Inr a  (Some a, h, (stk, loc, C0, M0, pc) # frs))}"

| "exec_instr (IfFalse i) P t h stk loc C0 M0 pc frs =
  {(ε, (let pc' = if hd stk = Bool False then nat(int pc+i) else pc+1
        in (None, h, (tl stk, loc, C0, M0, pc')#frs)) )}"

| exec_instr_Goto:
 "exec_instr (Goto i) P t h stk loc C0 M0 pc frs =
      {(ε, (None, h, (stk, loc, C0, M0, nat(int pc+i))#frs) )}"

| "exec_instr ThrowExc P t h stk loc C0 M0 pc frs =
  {(ε, (let xp' = if hd stk = Null then addr_of_sys_xcpt NullPointer else the_Addr(hd stk)
        in (xp', h, (stk, loc, C0, M0, pc)#frs)) )}"

| exec_instr_MEnter:
 "exec_instr MEnter P t h stk loc C0 M0 pc frs =
  {let v = hd stk
   in if v = Null
      then (ε, addr_of_sys_xcpt NullPointer, h, (stk, loc, C0, M0, pc) # frs)
      else (Lockthe_Addr v, SyncLock (the_Addr v), None, h, (tl stk, loc, C0, M0, pc + 1) # frs)}"

| exec_instr_MExit:
 "exec_instr MExit P t h stk loc C0 M0 pc frs =
  (let v = hd stk
   in if v = Null
      then {(ε, addr_of_sys_xcpt NullPointer, h, (stk, loc, C0, M0, pc)#frs)}
      else {(Unlockthe_Addr v, SyncUnlock (the_Addr v), None, h, (tl stk, loc, C0, M0, pc + 1) # frs),
            (UnlockFailthe_Addr v, addr_of_sys_xcpt IllegalMonitorState, h, (stk, loc, C0, M0, pc) # frs)})"

end

end

Theory JVMExceptions

(*  Title:      JinjaThreads/JVM/JVMExceptions.thy
    Author:     Gerwin Klein, Martin Strecker, Andreas Lochbihler
*)

section ‹Exception handling in the JVM›

theory JVMExceptions
imports
  JVMInstructions
begin

abbreviation Any :: "cname option"
where "Any  None"

definition matches_ex_entry :: "'m prog  cname  pc  ex_entry  bool"
where
 "matches_ex_entry P C pc xcp 
                 let (s, e, C', h, d) = xcp in
                 s  pc  pc < e  (case C' of None  True | C''  P  C * C'')"


primrec
  match_ex_table :: "'m prog  cname  pc  ex_table  (pc × nat) option"
where
  "match_ex_table P C pc []     = None"
| "match_ex_table P C pc (e#es) = (if matches_ex_entry P C pc e
                                   then Some (snd(snd(snd e)))
                                   else match_ex_table P C pc es)"

abbreviation ex_table_of :: "'addr jvm_prog  cname  mname  ex_table"
where "ex_table_of P C M == snd (snd (snd (the (snd (snd (snd(method P C M)))))))"

lemma match_ex_table_SomeD:
  "match_ex_table P C pc xt = Some (pc',d')  
  (f,t,D,h,d)  set xt. matches_ex_entry P C pc (f,t,D,h,d)  h = pc'  d=d'"
  by (induct xt) (auto split: if_split_asm)

end

Theory JVMExec

(*  Title:      JinjaThreads/JVM/JVMExec.thy
    Author:     Cornelia Pusch, Gerwin Klein, Andreas Lochbihler
*)

section ‹Program Execution in the JVM›

theory JVMExec
imports
  JVMExecInstr
  JVMExceptions
  "../Common/StartConfig"
begin

abbreviation instrs_of :: "'addr jvm_prog  cname  mname  'addr instr list"
where "instrs_of P C M == fst(snd(snd(the(snd(snd(snd(method P C M)))))))"

subsection "single step execution"

context JVM_heap_base begin

fun exception_step :: "'addr jvm_prog  'addr  'heap  'addr frame  'addr frame list  ('addr, 'heap) jvm_state"
where
  "exception_step P a h (stk, loc, C, M, pc) frs = 
   (case match_ex_table P (cname_of h a) pc (ex_table_of P C M) of
          None  (a, h, frs)
        | Some (pc', d)  (None, h, (Addr a # drop (size stk - d) stk, loc, C, M, pc') # frs))"

lemma exception_step_def_raw:
  "exception_step = 
   (λP a h (stk, loc, C, M, pc) frs.
    case match_ex_table P (cname_of h a) pc (ex_table_of P C M) of
      None  (a, h, frs)
    | Some (pc', d)  (None, h, (Addr a # drop (size stk - d) stk, loc, C, M, pc') # frs))"
by(intro ext) auto

fun exec :: "'addr jvm_prog  'thread_id  ('addr, 'heap) jvm_state  ('addr, 'thread_id, 'heap) jvm_ta_state set" where
  "exec P t (xcp, h, []) = {}"
| "exec P t (None, h, (stk, loc, C, M, pc) # frs) = exec_instr (instrs_of P C M ! pc) P t h stk loc C M pc frs"
| "exec P t (a, h, fr # frs) = {(ε, exception_step P a h fr frs)}"

subsection "relational view"

inductive exec_1 :: 
  "'addr jvm_prog  'thread_id  ('addr, 'heap) jvm_state
   ('addr, 'thread_id, 'heap) jvm_thread_action  ('addr, 'heap) jvm_state  bool"
  ("_,_ / _ -_-jvm→/ _" [61,0,61,0,61] 60)
  for P :: "'addr jvm_prog" and t :: 'thread_id
where
  exec_1I:
  "(ta, σ')  exec P t σ  P,t  σ -ta-jvm→ σ'"

lemma exec_1_iff:
  "P,t  σ -ta-jvm→ σ'  (ta, σ')  exec P t σ"
by(auto intro: exec_1I elim: exec_1.cases)

end

text ‹
  The start configuration of the JVM: in the start heap, we call a 
  method m› of class C› in program P› with parameters @{term "vs"}. The 
  this› pointer of the frame is set to Null› to simulate
  a static method invokation.
›

abbreviation JVM_local_start ::
  "cname  mname  ty list  ty  'addr jvm_method  'addr val list
   'addr jvm_thread_state"
where
  "JVM_local_start  
   λC M Ts T (mxs, mxl0, b) vs. 
   (None, [([], Null # vs @ replicate mxl0 undefined_value, C, M, 0)])"

context JVM_heap_base begin

abbreviation JVM_start_state :: 
  "'addr jvm_prog  cname  mname  'addr val list  ('addr,'thread_id,'addr jvm_thread_state,'heap,'addr) state"
where
  "JVM_start_state  start_state JVM_local_start"

definition JVM_start_state' :: "'addr jvm_prog  cname  mname  'addr val list  ('addr, 'heap) jvm_state"
where
  "JVM_start_state' P C M vs 
   let (D, Ts, T, meth) = method P C M;
       (mxs, mxl0, ins, xt) = the meth
   in (None, start_heap, [([], Null # vs @ replicate mxl0 undefined_value, D, M, 0)])"

end

end

Theory JVMDefensive

(*  Title:      JinjaThreads/JVM/JVMDefensive.thy
    Author:     Gerwin Klein, Andreas Lochbihler
*)

section ‹A Defensive JVM›

theory JVMDefensive
imports JVMExec "../Common/ExternalCallWF"
begin

text ‹
  Extend the state space by one element indicating a type error (or
  other abnormal termination)›
datatype 'a type_error = TypeError | Normal 'a

context JVM_heap_base begin

definition is_Array_ref :: "'addr val  'heap  bool" where
  "is_Array_ref v h  
  is_Ref v  
  (v  Null  typeof_addr h (the_Addr v)  None  is_Array (ty_of_htype (the (typeof_addr h (the_Addr v)))))"

declare is_Array_ref_def[simp]

primrec check_instr :: "['addr instr, 'addr jvm_prog, 'heap, 'addr val list, 'addr val list, 
                        cname, mname, pc, 'addr frame list]  bool"
where
  check_instr_Load:
  "check_instr (Load n) P h stk loc C M0 pc frs = 
  (n < length loc)"

| check_instr_Store:
  "check_instr (Store n) P h stk loc C0 M0 pc frs = 
  (0 < length stk  n < length loc)"

| check_instr_Push:
  "check_instr (Push v) P h stk loc C0 M0 pc frs = 
  (¬is_Addr v)"

| check_instr_New:
  "check_instr (New C) P h stk loc C0 M0 pc frs = 
  is_class P C"

| check_instr_NewArray:
  "check_instr (NewArray T) P h stk loc C0 M0 pc frs =
  (is_type P (T⌊⌉)  0 < length stk  is_Intg (hd stk))"

| check_instr_ALoad:
  "check_instr ALoad P h stk loc C0 M0 pc frs =
  (1 < length stk  is_Intg (hd stk)  is_Array_ref (hd (tl stk)) h)"

| check_instr_AStore:
  "check_instr AStore P h stk loc C0 M0 pc frs =
  (2 < length stk  is_Intg (hd (tl stk))  is_Array_ref (hd (tl (tl stk))) h  typeofh (hd stk)  None)"

| check_instr_ALength:
  "check_instr ALength P h stk loc C0 M0 pc frs =
  (0 < length stk  is_Array_ref (hd stk) h)"

| check_instr_Getfield:
  "check_instr (Getfield F C) P h stk loc C0 M0 pc frs = 
  (0 < length stk  (C' T fm. P  C sees F:T (fm) in C')  
  (let (C', T, fm) = field P C F; ref = hd stk in 
    C' = C  is_Ref ref  (ref  Null  
      (T. typeof_addr h (the_Addr ref) = T  P  class_type_of T * C))))"

| check_instr_Putfield:
  "check_instr (Putfield F C) P h stk loc C0 M0 pc frs = 
  (1 < length stk  (C' T fm. P  C sees F:T (fm) in C') 
  (let (C', T, fm) = field P C F; v = hd stk; ref = hd (tl stk) in 
    C' = C  is_Ref ref  (ref  Null  
      (T'. typeof_addr h (the_Addr ref) = T'  P  class_type_of T' * C  P,h  v :≤ T))))"

| check_instr_CAS:
  "check_instr (CAS F C) P h stk loc C0 M0 pc frs =
  (2 < length stk  (C' T fm. P  C sees F:T (fm) in C') 
  (let (C', T, fm) = field P C F; v'' = hd stk; v' = hd (tl stk); v = hd (tl (tl stk)) in
     C' = C  is_Ref v  volatile fm  (v  Null 
     (T'. typeof_addr h (the_Addr v) = T'  P  class_type_of T' * C  P,h  v' :≤ T  P,h  v'' :≤ T))))"

| check_instr_Checkcast:
  "check_instr (Checkcast T) P h stk loc C0 M0 pc frs =
  (0 < length stk  is_type P T)"

| check_instr_Instanceof:
  "check_instr (Instanceof T) P h stk loc C0 M0 pc frs =
  (0 < length stk  is_type P T  is_Ref (hd stk))"

| check_instr_Invoke:
  "check_instr (Invoke M n) P h stk loc C0 M0 pc frs =
  (n < length stk  is_Ref (stk!n)   
  (stk!n  Null  
    (let a = the_Addr (stk!n); 
         T = the (typeof_addr h a);
         C = class_type_of T;
         (D, Ts, Tr, meth) = method P C M
    in typeof_addr h a  None  P  C has M  
       P,h  rev (take n stk) [:≤] Ts  
       (meth = None  DM(Ts) :: Tr))))"

| check_instr_Return:
  "check_instr Return P h stk loc C0 M0 pc frs =
  (0 < length stk  ((0 < length frs)  
    (P  C0 has M0)     
    (let v = hd stk; 
         T = fst (snd (snd (method P C0 M0)))
     in P,h  v :≤ T)))"

| check_instr_Pop:
  "check_instr Pop P h stk loc C0 M0 pc frs = 
  (0 < length stk)"

| check_instr_Dup:
  "check_instr Dup P h stk loc C0 M0 pc frs = 
  (0 < length stk)"

| check_instr_Swap:
  "check_instr Swap P h stk loc C0 M0 pc frs =
  (1 < length stk)"

| check_instr_BinOpInstr:
  "check_instr (BinOpInstr bop) P h stk loc C0 M0 pc frs =
  (1 < length stk  (T1 T2 T. typeofh (hd stk) = T2  typeofh (hd (tl stk)) = T1  P  T1«bop»T2 : T))"

| check_instr_IfFalse:
  "check_instr (IfFalse b) P h stk loc C0 M0 pc frs =
  (0 < length stk  is_Bool (hd stk)  0  int pc+b)"

| check_instr_Goto:
  "check_instr (Goto b) P h stk loc C0 M0 pc frs =
  (0  int pc+b)"

| check_instr_Throw:
  "check_instr ThrowExc P h stk loc C0 M0 pc frs =
  (0 < length stk  is_Ref (hd stk)  P  the (typeofh (hd stk))  Class Throwable)"

| check_instr_MEnter:
  "check_instr MEnter P h stk loc C0 M0 pc frs =
   (0 < length stk  is_Ref (hd stk))"

| check_instr_MExit:
  "check_instr MExit P h stk loc C0 M0 pc frs =
   (0 < length stk  is_Ref (hd stk))"

definition check_xcpt :: "'addr jvm_prog  'heap  nat  pc  ex_table  'addr  bool"
where
  "check_xcpt P h n pc xt a 
  (C. typeof_addr h a = Class_type C  
  (case match_ex_table P C pc xt of None  True | Some (pc', d')  d'  n))"

definition check :: "'addr jvm_prog  ('addr, 'heap) jvm_state  bool"
where
  "check P σ  let (xcpt, h, frs) = σ in
               (case frs of []  True | (stk,loc,C,M,pc)#frs'  
                P  C has M 
                (let (C',Ts,T,meth) = method P C M; (mxs,mxl0,ins,xt) = the meth; i = ins!pc in
                 meth  None  pc < size ins  size stk  mxs 
                 (case xcpt of None  check_instr i P h stk loc C M pc frs'
                           | Some a  check_xcpt P h (length stk) pc xt a)))"


definition exec_d ::
  "'addr jvm_prog  'thread_id  ('addr, 'heap) jvm_state  ('addr, 'thread_id, 'heap) jvm_ta_state set type_error"
where
  "exec_d P t σ  if check P σ then Normal (exec P t σ) else TypeError"

inductive
  exec_1_d :: 
  "'addr jvm_prog  'thread_id  ('addr, 'heap) jvm_state type_error
   ('addr, 'thread_id, 'heap) jvm_thread_action  ('addr, 'heap) jvm_state type_error  bool" 
  ("_,_  _ -_-jvmd→ _" [61,0,61,0,61] 60)
  for P :: "'addr jvm_prog" and t :: 'thread_id
where
  exec_1_d_ErrorI: "exec_d P t σ = TypeError  P,t  Normal σ -ε-jvmd→ TypeError"
| exec_1_d_NormalI: " exec_d P t σ = Normal Σ; (tas, σ')  Σ    P,t  Normal σ -tas-jvmd→ Normal σ'"

lemma jvmd_NormalD:
  "P,t  Normal σ -ta-jvmd→ Normal σ'  check P σ  (ta, σ')  exec P t σ  (xcp h f frs. σ = (xcp, h, f # frs))"
apply(erule exec_1_d.cases, auto simp add: exec_d_def split: if_split_asm)
apply(case_tac b, auto)
done

lemma jvmd_NormalE:
  assumes "P,t  Normal σ -ta-jvmd→ Normal σ'"
  obtains xcp h f frs where "check P σ" "(ta, σ')  exec P t σ" "σ = (xcp, h, f # frs)"
using assms
by(auto dest: jvmd_NormalD)

lemma exec_d_eq_TypeError: "exec_d P t σ = TypeError  ¬ check P σ"
by(simp add: exec_d_def)

lemma exec_d_eq_Normal: "exec_d P t σ = Normal (exec P t σ)  check P σ"
by(auto simp add: exec_d_def)

end

declare split_paired_All [simp del]
declare split_paired_Ex [simp del]

lemma if_neq [dest!]:
  "(if P then A else B)  B  P"
  by (cases P, auto)

context JVM_heap_base begin

lemma exec_d_no_errorI [intro]:
  "check P σ  exec_d P t σ  TypeError"
  by (unfold exec_d_def) simp

theorem no_type_error_commutes:
  "exec_d P t σ  TypeError  exec_d P t σ = Normal (exec P t σ)"
  by (unfold exec_d_def, auto)

lemma defensive_imp_aggressive_1:
  "P,t  (Normal σ) -tas-jvmd→ (Normal σ')  P,t  σ -tas-jvm→ σ'"
by(auto elim!: exec_1_d.cases intro!: exec_1.intros simp add: exec_d_def split: if_split_asm)

end

context JVM_heap begin

lemma check_exec_hext:
  assumes exec: "(ta, xcp', h', frs')  exec P t (xcp, h, frs)"
  and check: "check P (xcp, h, frs)"
  shows "h  h'"
proof -
  from exec have "frs  []" by(auto)
  then obtain f Frs where frs [simp]: "frs = f # Frs"
    by(fastforce simp add: neq_Nil_conv)
  obtain stk loc C0 M0 pc where f [simp]: "f = (stk, loc, C0, M0, pc)"
    by(cases f, blast)
  show ?thesis
  proof(cases xcp)
    case None
    with check obtain C' Ts T mxs mxl0 ins xt
      where mthd: "P  C0 sees M0 : Ts  T = (mxs, mxl0, ins, xt) in C'"
                  "method P C0 M0 = (C', Ts, T, (mxs, mxl0, ins, xt))"
      and check_ins: "check_instr (ins ! pc) P h stk loc C0 M0 pc Frs"
      and "pc < length ins"
      and "length stk  mxs"
      by(auto simp add: check_def has_method_def)
    from None exec mthd
    have xexec: "(ta, xcp', h', frs')  exec_instr (ins ! pc) P t h stk loc C0 M0 pc Frs" by(clarsimp)
    thus ?thesis
    proof(cases "ins ! pc")
      case (New C)
      with xexec show ?thesis
        by(auto intro: hext_allocate split: if_split_asm)
    next
      case (NewArray T)
      with xexec show ?thesis
        by(auto intro: hext_allocate split: if_split_asm)
    next
      case AStore
      with xexec check_ins show ?thesis
        by(auto simp add: split_beta split: if_split_asm intro: hext_heap_write)
    next
      case Putfield
      with xexec check_ins show ?thesis
        by(auto intro: hext_heap_write simp add: split_beta split: if_split_asm)
    next
      case CAS
      with xexec check_ins show ?thesis
        by(auto intro: hext_heap_write simp add: split_beta split: if_split_asm)
    next
      case (Invoke M n)
      with xexec check_ins show ?thesis
        apply(auto simp add: min_def split_beta is_Ref_def extRet2JVM_def has_method_def
                split: if_split_asm intro: red_external_aggr_hext)
        apply(case_tac va)
        apply(auto 4 3 intro: red_external_aggr_hext is_native.intros)
        done
    next
      case (BinOpInstr bop)
      with xexec check_ins show ?thesis by(auto split: sum.split_asm)
    qed(auto simp add: split_beta split: if_split_asm)
  next
    case (Some a)
    with exec have "h' = h" by auto
    thus ?thesis by auto
  qed
qed

lemma exec_1_d_hext:
  " P,t  Normal (xcp, h, frs) -ta-jvmd→ Normal (xcp', h', frs')   h  h'"
by(auto elim!: exec_1_d.cases simp add: exec_d_def split: if_split_asm intro: check_exec_hext)

end

end

Theory JVMThreaded

(*  Title:      JinjaThreads/JVM/JVMDefensive.thy
    Author:     Andreas Lochbihler
*)

section ‹Instantiating the framework semantics with the JVM›

theory JVMThreaded
imports
  JVMDefensive
  "../Common/ConformThreaded"
  "../Framework/FWLiftingSem"
  "../Framework/FWProgressAux"
begin

primrec JVM_final :: "'addr jvm_thread_state  bool"
where
  "JVM_final (xcp, frs) = (frs = [])"

text‹The aggressive JVM›

context JVM_heap_base begin

abbreviation mexec :: 
  "'addr jvm_prog  'thread_id  ('addr jvm_thread_state × 'heap)
   ('addr, 'thread_id, 'heap) jvm_thread_action  ('addr jvm_thread_state × 'heap)  bool"
where
  "mexec P t  (λ((xcp, frstls), h) ta ((xcp', frstls'), h'). P,t  (xcp, h, frstls) -ta-jvm→ (xcp', h', frstls'))"

lemma NewThread_memory_exec_instr:
  " (ta, s)  exec_instr I P t h stk loc C M pc frs; NewThread t' x m  set tat   m = fst (snd s)"
apply(cases I)
apply(auto split: if_split_asm simp add: split_beta ta_upd_simps)
apply(auto dest!: red_ext_aggr_new_thread_heap simp add: extRet2JVM_def split: extCallRet.split)
done

lemma NewThread_memory_exec:
  " P,t  σ -ta-jvm→ σ'; NewThread t' x m  set tat   m = (fst (snd σ'))"
apply(erule exec_1.cases)
apply(clarsimp)
apply(case_tac bb, simp)
apply(case_tac ag, auto simp add: exception_step_def_raw split: list.split_asm)
apply(drule NewThread_memory_exec_instr, simp+)
done

lemma exec_instr_Wakeup_no_Lock_no_Join_no_Interrupt:
  " (ta, s)  exec_instr I P t h stk loc C M pc frs; Notified  set taw  WokenUp  set taw 
   collect_locks tal = {}  collect_cond_actions tac = {}  collect_interrupts tai = {}"
apply(cases I)
apply(auto split: if_split_asm simp add: split_beta ta_upd_simps dest: red_external_aggr_Wakeup_no_Join)
done

lemma mexec_instr_Wakeup_no_Join:
  " P,t  σ -ta-jvm→ σ'; Notified  set taw  WokenUp  set taw 
   collect_locks tal = {}  collect_cond_actions tac = {}  collect_interrupts tai = {}"
apply(erule exec_1.cases)
apply(clarsimp)
apply(case_tac bb, simp)
apply(case_tac ag, clarsimp simp add: exception_step_def_raw split: list.split_asm del: disjE)
apply(drule exec_instr_Wakeup_no_Lock_no_Join_no_Interrupt)
apply auto
done

lemma mexec_final: 
  " mexec P t (x, m) ta (x', m'); JVM_final x   False"
by(cases x)(auto simp add: exec_1_iff)

lemma exec_mthr: "multithreaded JVM_final (mexec P)"
apply(unfold_locales)
apply(clarsimp, drule NewThread_memory_exec, fastforce, simp)
apply(erule (1) mexec_final)
done

end

sublocale JVM_heap_base < exec_mthr: 
  multithreaded
    JVM_final
    "mexec P"
    convert_RA
  for P
by(rule exec_mthr)

context JVM_heap_base begin

abbreviation mexecT ::
  "'addr jvm_prog
   ('addr,'thread_id,'addr jvm_thread_state,'heap,'addr) state
   'thread_id × ('addr, 'thread_id, 'heap) jvm_thread_action
   ('addr,'thread_id,'addr jvm_thread_state,'heap,'addr) state  bool"
where
  "mexecT P  exec_mthr.redT P"

abbreviation mexecT_syntax1 ::
  "'addr jvm_prog  ('addr,'thread_id,'addr jvm_thread_state,'heap,'addr) state
   'thread_id  ('addr, 'thread_id, 'heap) jvm_thread_action
   ('addr,'thread_id,'addr jvm_thread_state,'heap,'addr) state  bool"
  ("_  _ -__jvm _" [50,0,0,0,50] 80)
where
  "mexecT_syntax1 P s t ta s'  mexecT P s (t, ta) s'"


abbreviation mExecT_syntax1 :: 
  "'addr jvm_prog  ('addr,'thread_id,'addr jvm_thread_state,'heap,'addr) state
   ('thread_id × ('addr, 'thread_id, 'heap) jvm_thread_action) list
   ('addr,'thread_id,'addr jvm_thread_state,'heap,'addr) state  bool"
  ("_  _ -▹_jvm* _" [50,0,0,50] 80)
where
  "P  s -▹ttasjvm* s'  exec_mthr.RedT P s ttas s'"

text‹The defensive JVM›

abbreviation mexecd :: 
  "'addr jvm_prog  'thread_id  'addr jvm_thread_state × 'heap 
   ('addr, 'thread_id, 'heap) jvm_thread_action  'addr jvm_thread_state × 'heap  bool"
where
  "mexecd P t  (λ((xcp, frstls), h) ta ((xcp', frstls'), h'). P,t  Normal (xcp, h, frstls) -ta-jvmd→ Normal (xcp', h', frstls'))"

lemma execd_mthr: "multithreaded JVM_final (mexecd P)"
apply(unfold_locales)
 apply(fastforce dest: defensive_imp_aggressive_1 NewThread_memory_exec)
apply(auto elim: jvmd_NormalE)
done

end

sublocale JVM_heap_base < execd_mthr:
  multithreaded
    JVM_final
    "mexecd P"
    convert_RA
  for P
by(rule execd_mthr)

context JVM_heap_base begin

abbreviation mexecdT ::
  "'addr jvm_prog  ('addr,'thread_id,'addr jvm_thread_state,'heap,'addr) state
   'thread_id × ('addr, 'thread_id, 'heap) jvm_thread_action
   ('addr,'thread_id,'addr jvm_thread_state,'heap,'addr) state  bool"
where
  "mexecdT P  execd_mthr.redT P"


abbreviation mexecdT_syntax1 ::
  "'addr jvm_prog  ('addr,'thread_id,'addr jvm_thread_state,'heap,'addr) state
   'thread_id  ('addr, 'thread_id, 'heap) jvm_thread_action
   ('addr,'thread_id,'addr jvm_thread_state,'heap,'addr) state  bool"
  ("_  _ -__jvmd _" [50,0,0,0,50] 80)
where
  "mexecdT_syntax1 P s t ta s'  mexecdT P s (t, ta) s'"

abbreviation mExecdT_syntax1 ::
  "'addr jvm_prog  ('addr,'thread_id,'addr jvm_thread_state,'heap,'addr) state
   ('thread_id × ('addr, 'thread_id, 'heap) jvm_thread_action) list
   ('addr,'thread_id,'addr jvm_thread_state,'heap,'addr) state  bool"
  ("_  _ -▹_jvmd* _" [50,0,0,50] 80)
where
  "P  s -▹ttasjvmd* s'  execd_mthr.RedT P s ttas s'"

lemma mexecd_Suspend_Invoke:
  " mexecd P t (x, m) ta (x', m'); Suspend w  set taw 
   stk loc C M pc frs' n a T Ts Tr D. x' = (None, (stk, loc, C, M, pc) # frs')  instrs_of P C M ! pc = Invoke wait n  stk ! n = Addr a  typeof_addr m a = T  P  class_type_of T sees wait:TsTr = Native in D  Dwait(Ts) :: Tr"
apply(cases x')
apply(cases x)
apply(cases "fst x")
apply(auto elim!: jvmd_NormalE simp add: split_beta)
apply(rename_tac [!] stk loc C M pc frs)
apply(case_tac [!] "instrs_of P C M ! pc")
apply(auto split: if_split_asm simp add: split_beta check_def is_Ref_def has_method_def)
apply(frule red_external_aggr_Suspend_StaySame, simp, drule red_external_aggr_Suspend_waitD, simp, fastforce)+
done

end

context JVM_heap begin

lemma exec_instr_New_Thread_exists_thread_object:
  " (ta, xcp', h', frs')  exec_instr ins P t h stk loc C M pc frs;
     check_instr ins P h stk loc C M pc frs;
     NewThread t' x h''  set tat 
   C. typeof_addr h' (thread_id2addr t') = Class_type C  P  C * Thread"
apply(cases ins)
apply(fastforce simp add: split_beta ta_upd_simps split: if_split_asm intro: red_external_aggr_new_thread_exists_thread_object)+
done

lemma exec_New_Thread_exists_thread_object:
  " P,t  Normal (xcp, h, frs) -ta-jvmd→ Normal (xcp', h', frs'); NewThread t' x h''  set tat 
   C. typeof_addr h' (thread_id2addr t') = Class_type C  P  C * Thread"
apply(cases xcp)
apply(case_tac [!] frs)
apply(auto simp add: check_def elim!: jvmd_NormalE dest!: exec_instr_New_Thread_exists_thread_object)
done

lemma exec_instr_preserve_tconf:
  " (ta, xcp', h', frs')  exec_instr ins P t h stk loc C M pc frs;
     check_instr ins P h stk loc C M pc frs;
     P,h  t' √t 
   P,h'  t' √t"
apply(cases ins)
apply(auto intro: tconf_hext_mono hext_allocate hext_heap_write red_external_aggr_preserves_tconf split: if_split_asm sum.split_asm simp add: split_beta has_method_def intro!: is_native.intros cong del: image_cong_simp)
done

lemma exec_preserve_tconf:
  " P,t  Normal (xcp, h, frs) -ta-jvmd→ Normal (xcp', h', frs'); P,h  t' √t   P,h'  t' √t"
apply(cases xcp)
apply(case_tac [!] frs)
apply(auto simp add: check_def elim!: jvmd_NormalE elim!: exec_instr_preserve_tconf)
done

lemma lifting_wf_thread_conf: "lifting_wf JVM_final (mexecd P) (λt x m. P,m  t √t)"
by(unfold_locales)(auto intro: exec_preserve_tconf dest: exec_New_Thread_exists_thread_object intro: tconfI)

end

sublocale JVM_heap < execd_tconf: lifting_wf JVM_final "mexecd P" convert_RA "λt x m. P,m  t √t"
by(rule lifting_wf_thread_conf)

context JVM_heap begin

lemma execd_hext:
  "P  s -ttajvmd s'  shr s  shr s'"
by(auto elim!: execd_mthr.redT.cases dest!: exec_1_d_hext intro: hext_trans)

lemma Execd_hext:
  assumes "P  s -▹ttajvmd* s'"
  shows "shr s  shr s'"
using assms unfolding execd_mthr.RedT_def
by(induct)(auto dest!: execd_hext intro: hext_trans simp add: execd_mthr.RedT_def)

end

end

Theory JVM_Main

theory JVM_Main
imports
  JVMState
  JVMThreaded
begin

end

Theory JVM_SemiType

(*  Title:      JinjaThreads/BV/JVM_SemiType.thy
    Author:     Gerwin Klein, Andreas Lochbihler

    Based on the theory Jinja/BV/JVM_SemiType
*)

chapter ‹Bytecode verifier›

section ‹The JVM Type System as Semilattice›

theory JVM_SemiType
imports
  "../Common/SemiType"
begin

type_synonym tyl = "ty err list"
type_synonym tys = "ty list"
type_synonym tyi = "tys × tyl"
type_synonym tyi' = "tyi option"
type_synonym tym = "tyi' list"
type_synonym tyP = "mname  cname  tym"

definition stk_esl :: "'c prog  nat  tys esl"
where
  "stk_esl P mxs  upto_esl mxs (SemiType.esl P)"

definition loc_sl :: "'c prog  nat  tyl sl"
where
  "loc_sl P mxl  Listn.sl mxl (Err.sl (SemiType.esl P))"

definition sl :: "'c prog  nat  nat  tyi' err sl"
where
  "sl P mxs mxl 
  Err.sl(Opt.esl(Product.esl (stk_esl P mxs) (Err.esl(loc_sl P mxl))))"

definition "states" :: "'c prog  nat  nat  tyi' err set"
where
  "states P mxs mxl  fst(sl P mxs mxl)"

definition le :: "'c prog  nat  nat  tyi' err ord"
where
  "le P mxs mxl  fst(snd(sl P mxs mxl))"

definition sup :: "'c prog  nat  nat  tyi' err binop"
where
  "sup P mxs mxl  snd(snd(sl P mxs mxl))"

definition sup_ty_opt :: "['c prog,ty err,ty err]  bool" 
  ("_  _  _" [71,71,71] 70)
where
  "sup_ty_opt P  Err.le (widen P)"

definition sup_state :: "['c prog,tyi,tyi]  bool"   
  ("_  _ i _" [71,71,71] 70)
where
  "sup_state P  Product.le (Listn.le (widen P)) (Listn.le (sup_ty_opt P))"

definition sup_state_opt :: "['c prog,tyi',tyi']  bool" 
  ("_  _ ≤'' _" [71,71,71] 70)
where
  "sup_state_opt P  Opt.le (sup_state P)"

abbreviation sup_loc :: "['c prog,tyl,tyl]  bool" ("_  _ [≤] _"  [71,71,71] 70)
where "P  LT [≤] LT'  list_all2 (sup_ty_opt P) LT LT'"

notation (ASCII)
  sup_ty_opt ("_ |- _ <=T _" [71,71,71] 70) and
  sup_state ("_ |- _ <=i _"  [71,71,71] 70) and
  sup_state_opt ("_ |- _ <=' _"  [71,71,71] 70) and
  sup_loc ("_ |- _ [<=T] _"  [71,71,71] 70)

subsection "Unfolding"

lemma JVM_states_unfold: 
  "states P mxs mxl  err(opt((Union {list n (types P) |n. n <= mxs}) ×
                                 list mxl (err(types P))))"
  apply (unfold states_def sl_def Opt.esl_def Err.sl_def
         stk_esl_def loc_sl_def Product.esl_def
         Listn.sl_def upto_esl_def SemiType.esl_def Err.esl_def)
  apply simp
  done

lemma JVM_le_unfold:
 "le P m n  
  Err.le(Opt.le(Product.le(Listn.le(widen P))(Listn.le(Err.le(widen P)))))" 
  apply (unfold le_def sl_def Opt.esl_def Err.sl_def
         stk_esl_def loc_sl_def Product.esl_def  
         Listn.sl_def upto_esl_def SemiType.esl_def Err.esl_def) 
  apply simp
  done

lemma sl_def2:
  "JVM_SemiType.sl P mxs mxl  
  (states P mxs mxl, JVM_SemiType.le P mxs mxl, JVM_SemiType.sup P mxs mxl)"
 by (unfold JVM_SemiType.sup_def states_def JVM_SemiType.le_def) simp 


lemma JVM_le_conv:
  "le P m n (OK t1) (OK t2) = P  t1 ≤' t2"
 by (simp add: JVM_le_unfold Err.le_def lesub_def sup_state_opt_def  
                sup_state_def sup_ty_opt_def) 

lemma JVM_le_Err_conv:
  "le P m n = Err.le (sup_state_opt P)"
 by (unfold sup_state_opt_def sup_state_def  
             sup_ty_opt_def JVM_le_unfold) simp 

lemma err_le_unfold [iff]: 
  "Err.le r (OK a) (OK b) = r a b"
 by (simp add: Err.le_def lesub_def) 
  

subsection ‹Semilattice›

lemma order_sup_state_opt [intro, simp]: 
  "wf_prog wf_mb P  order (sup_state_opt P)"   
 by (unfold sup_state_opt_def sup_state_def sup_ty_opt_def) blast 

lemma semilat_JVM [intro?]:
  "wf_prog wf_mb P  semilat (JVM_SemiType.sl P mxs mxl)"
  apply (unfold JVM_SemiType.sl_def stk_esl_def loc_sl_def)  
  apply (blast intro: err_semilat_Product_esl err_semilat_upto_esl 
                      Listn_sl err_semilat_JType_esl)
  done

lemma acc_JVM [intro]:
  "wf_prog wf_mb P  acc (JVM_SemiType.states P mxs mxl) (JVM_SemiType.le P mxs mxl)"
by(unfold JVM_le_unfold JVM_states_unfold) blast

subsection ‹Widening with ⊤›

lemma widen_refl[iff]: "widen P t t"  by (simp add: fun_of_def) 

lemma sup_ty_opt_refl [iff]: "P  T  T"
  apply (unfold sup_ty_opt_def)
  apply (fold lesub_def)
  apply (rule le_err_refl)
  apply (simp add: lesub_def)
  done

lemma Err_any_conv [iff]: "P  Err  T = (T = Err)"
 by (unfold sup_ty_opt_def) (rule Err_le_conv [simplified lesub_def]) 

lemma any_Err [iff]: "P  T  Err"
 by (unfold sup_ty_opt_def) (rule le_Err [simplified lesub_def]) 

lemma OK_OK_conv [iff]:
  "P  OK T  OK T' = P  T  T'"
 by (simp add: sup_ty_opt_def fun_of_def) 

lemma any_OK_conv [iff]:
  "P  X  OK T' = (T. X = OK T  P  T  T')"
  apply (unfold sup_ty_opt_def) 
  apply (rule le_OK_conv [simplified lesub_def])
  done  

lemma OK_any_conv:
 "P  OK T  X = (X = Err  (T'. X = OK T'  P  T  T'))"
  apply (unfold sup_ty_opt_def) 
  apply (rule OK_le_conv [simplified lesub_def])
  done

lemma sup_ty_opt_trans [intro?, trans]:
  "P  a  b; P  b  c  P  a  c"
 by (auto intro: widen_trans  
           simp add: sup_ty_opt_def Err.le_def lesub_def fun_of_def
           split: err.splits) 

subsection "Stack and Registers"

lemma stk_convert:
  "P  ST [≤] ST' = Listn.le (widen P) ST ST'"
 by (simp add: Listn.le_def lesub_def) 

lemma sup_loc_refl [iff]: "P  LT [≤] LT"
 by (rule list_all2_refl) simp 

lemmas sup_loc_Cons1 [iff] = list_all2_Cons1 [of "sup_ty_opt P"] for P

lemma sup_loc_def:
  "P  LT [≤] LT'  Listn.le (sup_ty_opt P) LT LT'"
 by (simp add: Listn.le_def lesub_def) 

lemma sup_loc_widens_conv [iff]:
  "P  map OK Ts [≤] map OK Ts' = P  Ts [≤] Ts'"
  by (simp add: list_all2_map1 list_all2_map2)

lemma sup_loc_trans [intro?, trans]:
  "P  a [≤] b; P  b [≤] c  P  a [≤] c"
 by (rule list_all2_trans, rule sup_ty_opt_trans) 

subsection "State Type"

lemma sup_state_conv [iff]:
  "P  (ST,LT) i (ST',LT') = (P  ST [≤] ST'  P  LT [≤] LT')"
 by (auto simp add: sup_state_def stk_convert lesub_def Product.le_def sup_loc_def) 
  
lemma sup_state_conv2:
  "P  s1 i s2 = (P  fst s1 [≤] fst s2  P  snd s1 [≤] snd s2)"
 by (cases s1, cases s2) simp 

lemma sup_state_refl [iff]: "P  s i s"
by (auto simp add: sup_state_conv2 intro: list_all2_refl)

lemma sup_state_trans [intro?, trans]:
  "P  a i b; P  b i c  P  a i c"
 by (auto intro: sup_loc_trans widens_trans simp add: sup_state_conv2) 

lemma sup_state_opt_None_any [iff]:
  "P  None ≤' s"
 by (simp add: sup_state_opt_def Opt.le_def) 

lemma sup_state_opt_any_None [iff]:
  "P  s ≤' None = (s = None)"
 by (simp add: sup_state_opt_def Opt.le_def) 

lemma sup_state_opt_Some_Some [iff]:
  "P  Some a ≤' Some b = P  a i b"  
 by (simp add: sup_state_opt_def Opt.le_def lesub_def) 

lemma sup_state_opt_any_Some:
  "P  (Some s) ≤' X = (s'. X = Some s'  P  s i s')"
 by (simp add: sup_state_opt_def Opt.le_def lesub_def) 

lemma sup_state_opt_refl [iff]: "P  s ≤' s"
 by (simp add: sup_state_opt_def Opt.le_def lesub_def) 

lemma sup_state_opt_trans [intro?, trans]:
  "P  a ≤' b; P  b ≤' c  P  a ≤' c"
  apply (unfold sup_state_opt_def Opt.le_def lesub_def)
  apply (simp del: split_paired_All)
  apply (rule sup_state_trans, assumption+)
  done

end

Theory Effect

(*  Title:      JinjaThreads/BV/Effect.thy
    Author:     Gerwin Klein, Andreas Lochbihler
*)

section ‹Effect of Instructions on the State Type›

theory Effect
imports
  JVM_SemiType
  "../JVM/JVMExceptions"
begin

locale jvm_method = prog +
  fixes mxs :: nat  
  fixes mxl0 :: nat   
  fixes Ts :: "ty list" 
  fixes Tr :: ty
  fixes "is" :: "'addr instr list" 
  fixes xt :: ex_table

  fixes mxl :: nat
  defines mxl_def: "mxl  1+size Ts+mxl0"

text ‹Program counter of successor instructions:›
primrec succs :: "'addr instr  tyi  pc  pc list"
where
  "succs (Load idx) τ pc     = [pc+1]"
| "succs (Store idx) τ pc    = [pc+1]"
| "succs (Push v) τ pc       = [pc+1]"
| "succs (Getfield F C) τ pc = [pc+1]"
| "succs (Putfield F C) τ pc = [pc+1]"
| "succs (CAS F C) τ pc      = [pc+1]"
| "succs (New C) τ pc        = [pc+1]"
| "succs (NewArray T) τ pc   = [pc+1]"
| "succs ALoad τ pc          = (if (fst τ)!1 = NT then [] else [pc+1])"
| "succs AStore τ pc         = (if (fst τ)!2 = NT then [] else [pc+1])"
| "succs ALength τ pc        = (if (fst τ)!0 = NT then [] else [pc+1])"
| "succs (Checkcast C) τ pc  = [pc+1]"
| "succs (Instanceof T) τ pc  = [pc+1]"
| "succs Pop τ pc            = [pc+1]"
| "succs Dup τ pc            = [pc+1]"
| "succs Swap τ pc           = [pc+1]"
| "succs (BinOpInstr b) τ pc = [pc+1]"
| succs_IfFalse:
  "succs (IfFalse b) τ pc    = [pc+1, nat (int pc + b)]"
| succs_Goto:
  "succs (Goto b) τ pc       = [nat (int pc + b)]"
| succs_Return:
  "succs Return τ pc         = []"  
| succs_Invoke:
  "succs (Invoke M n) τ pc   = (if (fst τ)!n = NT then [] else [pc+1])"
| succs_Throw:
  "succs ThrowExc τ pc          = []"
| "succs MEnter τ pc         = (if (fst τ)!0 = NT then [] else [pc+1])"
| "succs MExit τ pc          = (if (fst τ)!0 = NT then [] else [pc+1])"

text "Effect of instruction on the state type:"

fun effi :: "'addr instr × 'm prog × tyi  tyi"
where
  effi_Load:
  "effi (Load n,  P, (ST, LT))          = (ok_val (LT ! n) # ST, LT)"

| effi_Store:
  "effi (Store n, P, (T#ST, LT))        = (ST, LT[n:= OK T])"

| effi_Push:
  "effi (Push v, P, (ST, LT))             = (the (typeof v) # ST, LT)"

| effi_Getfield:
  "effi (Getfield F C, P, (T#ST, LT))    = (fst (snd (field P C F)) # ST, LT)"

| effi_Putfield:
  "effi (Putfield F C, P, (T1#T2#ST, LT)) = (ST,LT)"

| effi_CAS:
  "effi (CAS F C, P, (T1#T2#T3#ST, LT)) = (Boolean # ST, LT)"

| effi_New:
  "effi (New C, P, (ST,LT))               = (Class C # ST, LT)"

| effi_NewArray:
  "effi (NewArray Ty, P, (T#ST,LT))       = (Ty⌊⌉ # ST,LT)"

| effi_ALoad:
  "effi (ALoad, P, (T1#T2#ST,LT))       = (the_Array T2# ST,LT)"

| effi_AStore:
  "effi (AStore, P, (T1#T2#T3#ST,LT))  = (ST,LT)"

| effi_ALength:
  "effi (ALength, P, (T1#ST,LT))  = (Integer#ST,LT)"

| effi_Checkcast:
  "effi (Checkcast Ty, P, (T#ST,LT))       = (Ty # ST,LT)"

| effi_Instanceof:
  "effi (Instanceof Ty, P, (T#ST,LT))       = (Boolean # ST,LT)"

| effi_Pop:
  "effi (Pop, P, (T#ST,LT))               = (ST,LT)"

| effi_Dup:
  "effi (Dup, P, (T#ST,LT))               = (T#T#ST,LT)"

| effi_Swap:
  "effi (Swap, P, (T1#T2#ST,LT))               = (T2#T1#ST,LT)"

| effi_BinOpInstr:
  "effi (BinOpInstr bop, P, (T2#T1#ST,LT)) = ((THE T. P  T1«bop»T2 : T)#ST, LT)"

| effi_IfFalse:
  "effi (IfFalse b, P, (T1#ST,LT))        = (ST,LT)"

| effi_Invoke:
  "effi (Invoke M n, P, (ST,LT))          =
  (let U = fst (snd (snd (method P (the (class_type_of' (ST ! n))) M)))
   in (U # drop (n+1) ST, LT))"

| effi_Goto:
  "effi (Goto n, P, s)                    = s"

| effi_MEnter:
  "effi (MEnter, P, (T1#ST,LT))           = (ST,LT)"

| effi_MExit:
  "effi (MExit, P, (T1#ST,LT))            = (ST,LT)"


fun is_relevant_class :: "'addr instr  'm prog  cname  bool" 
where
  rel_Getfield:
  "is_relevant_class (Getfield F D) = (λP C. P  NullPointer * C)" 
| rel_Putfield:
  "is_relevant_class (Putfield F D) = (λP C. P  NullPointer * C)" 
| rel_CAS:
  "is_relevant_class (CAS F D)      = (λP C. P  NullPointer * C)" 
| rel_Checcast:
  "is_relevant_class (Checkcast T)  = (λP C. P  ClassCast * C)" 
| rel_New:
  "is_relevant_class (New D)        = (λP C. P  OutOfMemory * C)" 
| rel_Throw:
  "is_relevant_class ThrowExc       = (λP C. True)"
| rel_Invoke:
  "is_relevant_class (Invoke M n)   = (λP C. True)"
| rel_NewArray:
  "is_relevant_class (NewArray T)   = (λP C. (P  OutOfMemory * C)  (P  NegativeArraySize * C))"
| rel_ALoad:
  "is_relevant_class ALoad          = (λP C. P  ArrayIndexOutOfBounds * C  P  NullPointer * C)"
| rel_AStore:
  "is_relevant_class AStore         = (λP C. P  ArrayIndexOutOfBounds * C  P  ArrayStore * C  P  NullPointer * C)"
| rel_ALength:
  "is_relevant_class ALength        = (λP C. P  NullPointer * C)"
| rel_MEnter:
  "is_relevant_class MEnter         = (λP C. P  IllegalMonitorState * C  P  NullPointer * C)"
| rel_MExit:
  "is_relevant_class MExit          = (λP C. P  IllegalMonitorState * C  P  NullPointer * C)"
| rel_BinOp:
  "is_relevant_class (BinOpInstr bop) = binop_relevant_class bop"
| rel_default:
  "is_relevant_class i              = (λP C. False)"

definition is_relevant_entry :: "'m prog  'addr instr  pc  ex_entry  bool" 
where
  "is_relevant_entry P i pc e  
   let (f,t,C,h,d) = e 
   in (case C of None  True | C'  is_relevant_class i P C')  pc  {f..<t}"

definition relevant_entries :: "'m prog  'addr instr  pc  ex_table  ex_table" 
where
  "relevant_entries P i pc  filter (is_relevant_entry P i pc)"

definition xcpt_eff :: "'addr instr  'm prog  pc  tyi  ex_table  (pc × tyi') list"
where
  "xcpt_eff i P pc τ et  let (ST,LT) = τ in 
  map (λ(f,t,C,h,d). (h, Some ((case C of None  Class Throwable | Some C'  Class C')#drop (size ST - d) ST, LT))) (relevant_entries P i pc et)"

definition norm_eff :: "'addr instr  'm prog  nat  tyi  (pc × tyi') list"
where "norm_eff i P pc τ  map (λpc'. (pc',Some (effi (i,P,τ)))) (succs i τ pc)"

definition eff :: "'addr instr  'm prog  pc  ex_table  tyi'  (pc × tyi') list"
where
  "eff i P pc et t 
  case t of           
    None  []          
  | Some τ  (norm_eff i P pc τ) @ (xcpt_eff i P pc τ et)"


lemma eff_None:
  "eff i P pc xt None = []"
by (simp add: eff_def)

lemma eff_Some:
  "eff i P pc xt (Some τ) = norm_eff i P pc τ @ xcpt_eff i P pc τ xt"
by (simp add: eff_def)

(* FIXME: getfield, ∃T D. P ⊢ C sees F:T in D ∧ .. *)

text "Conditions under which eff is applicable:"

fun appi :: "'addr instr × 'm prog × pc × nat × ty × tyi  bool"
where
  appi_Load:
  "appi (Load n, P, pc, mxs, Tr, (ST,LT)) = 
    (n < length LT  LT ! n  Err  length ST < mxs)"
| appi_Store:
  "appi (Store n, P, pc, mxs, Tr, (T#ST, LT)) = 
    (n < length LT)"
| appi_Push:
  "appi (Push v, P, pc, mxs, Tr, (ST,LT)) = 
    (length ST < mxs  typeof v  None)"
| appi_Getfield:
  "appi (Getfield F C, P, pc, mxs, Tr, (T#ST, LT)) = 
    (Tf fm. P  C sees F:Tf (fm) in C  P  T  Class C)"
| appi_Putfield:
  "appi (Putfield F C, P, pc, mxs, Tr, (T1#T2#ST, LT)) = 
    (Tf fm. P  C sees F:Tf (fm) in C  P  T2  (Class C)  P  T1  Tf)" 
| appi_CAS:
  "appi (CAS F C, P, pc, mxs, Tr, (T3#T2#T1#ST, LT)) = 
    (Tf fm. P  C sees F:Tf (fm) in C  volatile fm  P  T1  Class C  P  T2  Tf  P  T3  Tf)" 
| appi_New:
  "appi (New C, P, pc, mxs, Tr, (ST,LT)) = 
    (is_class P C  length ST < mxs)"
| appi_NewArray:
  "appi (NewArray Ty, P, pc, mxs, Tr, (Integer#ST,LT)) = 
    is_type P (Ty⌊⌉)"
|  appi_ALoad:
  "appi (ALoad, P, pc, mxs, Tr, (T1#T2#ST,LT)) = 
    (T1 = Integer  (T2  NT  (Ty. T2 = Ty⌊⌉)))"
| appi_AStore:
  "appi (AStore, P, pc, mxs, Tr, (T1#T2#T3#ST,LT)) = 
    (T2 = Integer  (T3  NT  (Ty. T3 = Ty⌊⌉)))"
| appi_ALength:
  "appi (ALength, P, pc, mxs, Tr, (T1#ST,LT)) = 
    (T1 = NT  (Ty. T1 = Ty⌊⌉))"
| appi_Checkcast:
  "appi (Checkcast Ty, P, pc, mxs, Tr, (T#ST,LT)) = 
    (is_type P Ty)"
| appi_Instanceof:
  "appi (Instanceof Ty, P, pc, mxs, Tr, (T#ST,LT)) = 
    (is_type P Ty  is_refT T)"
| appi_Pop:
  "appi (Pop, P, pc, mxs, Tr, (T#ST,LT)) = 
    True"
| appi_Dup:
  "appi (Dup, P, pc, mxs, Tr, (T#ST,LT)) = 
    (Suc (length ST) < mxs)"
| appi_Swap:
  "appi (Swap, P, pc, mxs, Tr, (T1#T2#ST,LT)) = True"
| appi_BinOpInstr:
  "appi (BinOpInstr bop, P, pc, mxs, Tr, (T2#T1#ST,LT)) = (T. P  T1«bop»T2 : T)"
| appi_IfFalse:
  "appi (IfFalse b, P, pc, mxs, Tr, (Boolean#ST,LT)) = 
    (0  int pc + b)"
| appi_Goto:
  "appi (Goto b, P, pc, mxs, Tr, s) =  (0  int pc + b)"
| appi_Return:
  "appi (Return, P, pc, mxs, Tr, (T#ST,LT)) = (P  T  Tr)"
| appi_Throw:
  "appi (ThrowExc, P, pc, mxs, Tr, (T#ST,LT)) = 
    (T = NT  (C. T = Class C  P  C * Throwable))"
| appi_Invoke:
  "appi (Invoke M n, P, pc, mxs, Tr, (ST,LT)) =
    (n < length ST  
    (ST!n  NT 
      (C D Ts T m. class_type_of' (ST ! n) = C  P  C sees M:Ts  T = m in D  P  rev (take n ST) [≤] Ts)))"
| appi_MEnter:
  "appi (MEnter,P, pc,mxs,Tr,(T#ST,LT)) = (is_refT T)"
| appi_MExit:
  "appi (MExit,P, pc,mxs,Tr,(T#ST,LT)) = (is_refT T)"
| appi_default:
  "appi (i,P, pc,mxs,Tr,s) = False"


definition xcpt_app :: "'addr instr  'm prog  pc  nat  ex_table  tyi  bool"
where
  "xcpt_app i P pc mxs xt τ  (f,t,C,h,d)  set (relevant_entries P i pc xt). (case C of None  True | Some C'  is_class P C')  d  size (fst τ)  d < mxs"

definition app :: "'addr instr  'm prog  nat  ty  nat  nat  ex_table  tyi'  bool"
where
  "app i P mxs Tr pc mpc xt t  case t of None  True | Some τ  
  appi (i,P,pc,mxs,Tr,τ)  xcpt_app i P pc mxs xt τ  
  ((pc',τ')  set (eff i P pc xt t). pc' < mpc)"


lemma app_Some:
  "app i P mxs Tr pc mpc xt (Some τ) = 
  (appi (i,P,pc,mxs,Tr,τ)  xcpt_app i P pc mxs xt τ  
  ((pc',s')  set (eff i P pc xt (Some τ)). pc' < mpc))"
by (simp add: app_def)

locale eff = jvm_method +
  fixes effi and appi and eff and app 
  fixes norm_eff and xcpt_app and xcpt_eff

  fixes mpc
  defines "mpc  size is"

  defines "effi i τ  Effect.effi (i,P,τ)"
  notes effi_simps [simp] = Effect.effi.simps [where P = P, folded effi_def]

  defines "appi i pc τ  Effect.appi (i, P, pc, mxs, Tr, τ)"
  notes appi_simps [simp] = Effect.appi.simps [where P=P and mxs=mxs and Tr=Tr, folded appi_def]

  defines "xcpt_eff i pc τ  Effect.xcpt_eff i P pc τ xt"
  notes xcpt_eff = Effect.xcpt_eff_def [of _ P _ _ xt, folded xcpt_eff_def]

  defines "norm_eff i pc τ  Effect.norm_eff i P pc τ"
  notes norm_eff = Effect.norm_eff_def [of _ P, folded norm_eff_def effi_def]

  defines "eff i pc  Effect.eff i P pc xt"
  notes eff = Effect.eff_def [of _ P  _ xt, folded eff_def norm_eff_def xcpt_eff_def]

  defines "xcpt_app i pc τ  Effect.xcpt_app i P pc mxs xt τ"
  notes xcpt_app = Effect.xcpt_app_def [of _ P _ mxs xt, folded xcpt_app_def]

  defines "app i pc  Effect.app i P mxs Tr pc mpc xt"
  notes app = Effect.app_def [of _ P mxs Tr _ mpc xt, folded app_def xcpt_app_def appi_def eff_def]


lemma length_cases2:
  assumes "LT. P ([],LT)"
  assumes "l ST LT. P (l#ST,LT)"
  shows "P s"
  by (cases s, cases "fst s") (auto intro!: assms)


lemma length_cases3:
  assumes "LT. P ([],LT)"
  assumes "l LT. P ([l],LT)"
  assumes "l l' ST LT. P (l#l'#ST,LT)"
  shows "P s"
  apply(rule length_cases2; (rule assms)?)
  subgoal for l ST LT by(cases ST; clarsimp simp: assms)
  done

lemma length_cases4:
  assumes "LT. P ([],LT)"
  assumes "l LT. P ([l],LT)"
  assumes "l l' LT. P ([l,l'],LT)"
  assumes "l l' l'' ST LT. P (l#l'#l''#ST,LT)"
  shows "P s"
  apply(rule length_cases3; (rule assms)?)
  subgoal for l l' ST LT by(cases ST; clarsimp simp: assms)
  done

lemma length_cases5:
  assumes "LT. P ([],LT)"
  assumes "l LT. P ([l],LT)"
  assumes "l l' LT. P ([l,l'],LT)"
  assumes "l l' l'' LT. P ([l,l',l''],LT)"
  assumes "l l' l'' l''' ST LT. P (l#l'#l''#l'''#ST,LT)"
  shows "P s"
  apply(rule length_cases4; (rule assms)?)
  subgoal for l l' l'' ST LT by(cases ST; clarsimp simp: assms)
  done

text ‹
\medskip
simp rules for @{term app}
lemma appNone[simp]: "app i P mxs Tr pc mpc et None = True" 
  by (simp add: app_def)


lemma appLoad[simp]:
"appi (Load idx, P, Tr, mxs, pc, s) = (ST LT. s = (ST,LT)  idx < length LT  LT!idx  Err  length ST < mxs)"
  by (cases s, simp)

lemma appStore[simp]:
"appi (Store idx,P,pc,mxs,Tr,s) = (ts ST LT. s = (ts#ST,LT)  idx < length LT)"
  by (rule length_cases2, auto)

lemma appPush[simp]:
"appi (Push v,P,pc,mxs,Tr,s) =
 (ST LT. s = (ST,LT)  length ST < mxs  typeof v  None)"
  by (cases s, simp)

lemma appGetField[simp]:
"appi (Getfield F C,P,pc,mxs,Tr,s) = 
 ( oT vT ST LT fm. s = (oT#ST, LT)  
  P  C sees F:vT (fm) in C  P  oT  (Class C))"
  by (rule length_cases2 [of _ s]) auto

lemma appPutField[simp]:
"appi (Putfield F C,P,pc,mxs,Tr,s) = 
 ( vT vT' oT ST LT fm. s = (vT#oT#ST, LT) 
  P  C sees F:vT' (fm) in C  P  oT  (Class C)  P  vT  vT')"
  by (rule length_cases4 [of _ s], auto)

lemma appCAS[simp]:
"appi (CAS F C, P, pc, mxs, Tr, s) =
  ( T1 T2 T3 T' ST LT fm. s = (T3 # T2 # T1 # ST, LT) 
  P  C sees F:T' (fm) in C  volatile fm  P  T1  Class C  P  T2  T'  P  T3  T')"
  by(rule length_cases4[of _ s]) auto

lemma appNew[simp]:
  "appi (New C,P,pc,mxs,Tr,s) = 
  (ST LT. s=(ST,LT)  is_class P C  length ST < mxs)"
  by (cases s, simp)

lemma appNewArray[simp]:
  "appi (NewArray Ty,P,pc,mxs,Tr,s) = 
  (ST LT. s=(Integer#ST,LT)  is_type P (Ty⌊⌉))"
  by (cases s, simp, cases "fst s", simp)(cases "hd (fst s)", auto)

lemma appALoad[simp]:
  "appi (ALoad,P,pc,mxs,Tr,s) = 
  (T ST LT. s=(Integer#T#ST,LT)  (T  NT  (T'.  T = T'⌊⌉)))"
proof -
  obtain ST LT where [simp]: "s = (ST, LT)" by (cases s)
  have "ST = []  (T. ST = [T])  (T1 T2 ST'. ST = T1#T2#ST')"
    by (cases ST, auto, case_tac list, auto)
  moreover
  { assume "ST = []" hence ?thesis by simp }
  moreover
  { fix T assume "ST = [T]" hence ?thesis by (cases T, auto) }
  moreover
  { fix T1 T2 ST' assume "ST = T1#T2#ST'"
    hence ?thesis by (cases T1, auto)
  }
  ultimately show ?thesis by blast
qed

lemma appAStore[simp]:
  "appi (AStore,P,pc,mxs,Tr,s) = 
  (T U ST LT. s=(T#Integer#U#ST,LT)  (U  NT  (T'. U = T'⌊⌉)))"
proof -
  obtain ST LT where [simp]: "s = (ST, LT)" by (cases s)
  have "ST = []  (T. ST = [T])  (T1 T2. ST = [T1, T2])  (T1 T2 T3 ST'. ST = T1 # T2 # T3 # ST')"
    by (cases ST, auto, case_tac list, auto, case_tac lista, auto)
  moreover
  { assume "ST = []" hence ?thesis by simp }
  moreover
  { fix T assume "ST = [T]" hence ?thesis by(simp) }
  moreover
  { fix T1 T2 assume "ST = [T1, T2]" hence ?thesis by simp }
  moreover
  { fix T1 T2 T3 ST' assume "ST = T1 # T2 # T3 # ST'" hence ?thesis by(cases T2, auto) }
  ultimately show ?thesis by blast
qed

lemma appALength[simp]:
  "appi (ALength,P,pc,mxs,Tr,s) = 
  (T ST LT. s=(T#ST,LT)  (T  NT  (T'.  T = T'⌊⌉)))"
  by (cases s, cases "fst s", simp add: app_def) (cases "hd (fst s)", auto)

lemma appCheckcast[simp]: 
  "appi (Checkcast Ty,P,pc,mxs,Tr,s) =  
  (T ST LT. s = (T#ST,LT)  is_type P Ty)"
  by (cases s, cases "fst s", simp add: app_def) (cases "hd (fst s)", auto)

lemma appInstanceof[simp]: 
  "appi (Instanceof Ty,P,pc,mxs,Tr,s) =  
  (T ST LT. s = (T#ST,LT)  is_type P Ty  is_refT T)"
  by (cases s, cases "fst s", simp add: app_def) (cases "hd (fst s)", auto)

lemma appiPop[simp]: 
"appi (Pop,P,pc,mxs,Tr,s) = (ts ST LT. s = (ts#ST,LT))"
  by (rule length_cases2, auto)

lemma appDup[simp]:
"appi (Dup,P,pc,mxs,Tr,s) =
 (T ST LT. s = (T#ST,LT)  Suc (length ST) < mxs)"
by (cases s, cases "fst s", simp_all)

lemma appiSwap[simp]: 
"appi (Swap,P,pc,mxs,Tr,s) = (T1 T2 ST LT. s = (T1#T2#ST,LT))"
by(rule length_cases4) auto

lemma appBinOp[simp]:
"appi (BinOpInstr bop,P,pc,mxs,Tr,s) = (T1 T2 ST LT T. s = (T2 # T1 # ST, LT)  P  T1«bop»T2 : T)"
proof -
  obtain ST LT where [simp]: "s = (ST,LT)" by (cases s)
  have "ST = []  (T. ST = [T])  (T1 T2 ST'. ST = T1#T2#ST')"
    by (cases ST, auto, case_tac list, auto)
  moreover
  { assume "ST = []" hence ?thesis by simp }
  moreover
  { fix T assume "ST = [T]" hence ?thesis by (cases T, auto) }
  moreover
  { fix T1 T2 ST' assume "ST = T1#T2#ST'"
    hence ?thesis by simp
  }
  ultimately show ?thesis by blast
qed

lemma appIfFalse [simp]:
"appi (IfFalse b,P,pc,mxs,Tr,s) = 
  (ST LT. s = (Boolean#ST,LT)  0  int pc + b)"
  apply (rule length_cases2)
  apply simp
  apply (case_tac l) 
  apply auto
  done

lemma appReturn[simp]:
"appi (Return,P,pc,mxs,Tr,s) = (T ST LT. s = (T#ST,LT)  P  T  Tr)" 
  by (rule length_cases2, auto)

lemma appThrow[simp]:
  "appi (ThrowExc,P,pc,mxs,Tr,s) = (T ST LT. s=(T#ST,LT)  (T = NT  (C. T = Class C  P  C * Throwable)))"
  by (rule length_cases2, auto)  

lemma appMEnter[simp]:
  "appi (MEnter,P,pc,mxs,Tr,s) = (T ST LT. s=(T#ST,LT)  is_refT T)"
  by (rule length_cases2, auto)  

lemma appMExit[simp]:
  "appi (MExit,P,pc,mxs,Tr,s) = (T ST LT. s=(T#ST,LT)  is_refT T)"
  by (rule length_cases2, auto)

lemma effNone: 
  "(pc', s')  set (eff i P pc et None)  s' = None"
  by (auto simp add: eff_def xcpt_eff_def norm_eff_def)


lemma relevant_entries_append [simp]:
  "relevant_entries P i pc (xt @ xt') = relevant_entries P i pc xt @ relevant_entries P i pc xt'"
  by (unfold relevant_entries_def) simp

lemma xcpt_app_append [iff]:
  "xcpt_app i P pc mxs (xt@xt') τ = (xcpt_app i P pc mxs xt τ  xcpt_app i P pc mxs xt' τ)"
unfolding xcpt_app_def by force

lemma xcpt_eff_append [simp]:
  "xcpt_eff i P pc τ (xt@xt') = xcpt_eff i P pc τ xt @ xcpt_eff i P pc τ xt'"
 by (unfold xcpt_eff_def, cases τ) simp

lemma app_append [simp]:
  "app i P pc T mxs mpc (xt@xt') τ = (app i P pc T mxs mpc xt τ  app i P pc T mxs mpc xt' τ)"
  by (unfold app_def eff_def) auto


subsection ‹Code generator setup›

declare list_all2_Nil [code]
declare list_all2_Cons [code]

lemma effi_BinOpInstr_code:
  "effi (BinOpInstr bop, P, (T2#T1#ST,LT)) = (Predicate.the (WTrt_binop_i_i_i_i_o P T1 bop T2) # ST, LT)"
by(simp add: the_WTrt_binop_code)

lemmas effi_code[code] =
  effi_Load effi_Store effi_Push effi_Getfield effi_Putfield effi_New effi_NewArray effi_ALoad
  effi_AStore effi_ALength effi_Checkcast effi_Instanceof effi_Pop effi_Dup effi_Swap effi_BinOpInstr_code
  effi_IfFalse effi_Invoke effi_Goto effi_MEnter effi_MExit

lemma appi_Getfield_code:
  "appi (Getfield F C, P, pc, mxs, Tr, (T#ST, LT)) 
  Predicate.holds (Predicate.bind (sees_field_i_i_i_o_o_i P C F C) (λT. Predicate.single ()))  P  T  Class C"
apply(clarsimp simp add: Predicate.bind_def Predicate.single_def holds_eq eval_sees_field_i_i_i_o_i_conv)
done
 
lemma appi_Putfield_code:
  "appi (Putfield F C, P, pc, mxs, Tr, (T1#T2#ST, LT)) 
   P  T2  (Class C) 
   Predicate.holds (Predicate.bind (sees_field_i_i_i_o_o_i P C F C) (λ(T, fm). if P  T1  T then Predicate.single () else bot))"
by (auto simp add: holds_eq eval_sees_field_i_i_i_o_i_conv split: if_splits)

lemma appi_CAS_code:
  "appi (CAS F C, P, pc, mxs, Tr, (T3#T2#T1#ST, LT)) 
   P  T1  Class C 
  Predicate.holds (Predicate.bind (sees_field_i_i_i_o_o_i P C F C) (λ(T, fm). if P  T2  T  P  T3  T  volatile fm then Predicate.single () else bot))"
by(auto simp add: holds_eq eval_sees_field_i_i_i_o_i_conv)

lemma appi_ALoad_code:
  "appi (ALoad, P, pc, mxs, Tr, (T1#T2#ST,LT)) = 
   (T1 = Integer  (case T2 of Ty⌊⌉  True | NT  True | _  False))"
by(simp add: split: ty.split)

lemma appi_AStore_code:
  "appi (AStore, P, pc, mxs, Tr, (T1#T2#T3#ST,LT)) = 
  (T2 = Integer  (case T3 of Ty⌊⌉  True | NT  True | _  False))"
by(simp add: split: ty.split)

lemma appi_ALength_code:
  "appi (ALength, P, pc, mxs, Tr, (T1#ST,LT)) = 
   (case T1 of Ty⌊⌉  True | NT  True | _  False)"
by(simp add: split: ty.split)

lemma appi_BinOpInstr_code:
  "appi (BinOpInstr bop, P, pc, mxs, Tr, (T2#T1#ST,LT)) = 
   Predicate.holds (Predicate.bind (WTrt_binop_i_i_i_i_o P T1 bop T2) (λT. Predicate.single ()))"
by (auto simp add: holds_eq eval_WTrt_binop_i_i_i_i_o)

lemma appi_Invoke_code:
  "appi (Invoke M n, P, pc, mxs, Tr, (ST,LT)) =
  (n < length ST  
  (ST!n  NT 
     (case class_type_of' (ST ! n) of Some C  
         Predicate.holds (Predicate.bind (Method_i_i_i_o_o_o_o P C M) 
                                          (λ(Ts, _). if P  rev (take n ST) [≤] Ts then Predicate.single () else bot))
      | _  False)))"
proof -
  have bind_Ex: "P f. Predicate.bind P f = Predicate.Pred (λx. (y. Predicate.eval P y  Predicate.eval (f y) x))"
    by (rule pred_eqI) auto
  thus ?thesis
    by (auto simp add: bind_Ex Predicate.single_def holds_eq eval_Method_i_i_i_o_o_o_o_conv split: ty.split)
qed

lemma appi_Throw_code:
  "appi (ThrowExc, P, pc, mxs, Tr, (T#ST,LT)) = 
  (case T of NT  True | Class C  P  C * Throwable | _  False)"
by(simp split: ty.split)

lemmas appi_code [code] =
  appi_Load appi_Store appi_Push
  appi_Getfield_code appi_Putfield_code appi_CAS_code
  appi_New appi_NewArray
  appi_ALoad_code appi_AStore_code appi_ALength_code
  appi_Checkcast appi_Instanceof
  appi_Pop appi_Dup appi_Swap appi_BinOpInstr_code appi_IfFalse appi_Goto
  appi_Return appi_Throw_code appi_Invoke_code appi_MEnter appi_MExit
  appi_default

end

Theory BVSpec

(*  Title:      JinjaThreads/BV/BVSpec.thy
    Author:     Cornelia Pusch, Gerwin Klein, Andreas Lochbihler

    Based on the theory Jinja/BV/BVSpec
*)

section ‹The Bytecode Verifier \label{sec:BVSpec}›

theory BVSpec
imports
  Effect
begin

text ‹
  This theory contains a specification of the BV. The specification
  describes correct typings of method bodies; it corresponds 
  to type \emph{checking}.
›

― ‹The method type only contains declared classes:›
definition check_types :: "'m prog  nat  nat  tyi' err list  bool"
where  
  "check_types P mxs mxl τs  set τs  states P mxs mxl"

― ‹An instruction is welltyped if it is applicable and its effect›
― ‹is compatible with the type at all successor instructions:›
definition wt_instr :: "['m prog,ty,nat,pc,ex_table,'addr instr,pc,tym]  bool"
  ("_,_,_,_,_  _,_ :: _" [60,0,0,0,0,0,0,61] 60)
where
  "P,T,mxs,mpc,xt  i,pc :: τs 
  app i P mxs T pc mpc xt (τs!pc)  
  ((pc',τ')  set (eff i P pc xt (τs!pc)). P  τ' ≤' τs!pc')"

― ‹The type at @{text "pc=0"} conforms to the method calling convention:›
definition wt_start :: "['m prog,cname,ty list,nat,tym]  bool"
where
  "wt_start P C Ts mxl0 τs 
  P  Some ([],OK (Class C)#map OK Ts@replicate mxl0 Err) ≤' τs!0"

― ‹A method is welltyped if the body is not empty,›
― ‹if the method type covers all instructions and mentions›
― ‹declared classes only, if the method calling convention is respected, and›
― ‹if all instructions are welltyped.›
definition wt_method :: "['m prog,cname,ty list,ty,nat,nat,'addr instr list, ex_table,tym]  bool"
where
  "wt_method P C Ts Tr mxs mxl0 is xt τs 
  0 < size is  size τs = size is 
  check_types P mxs (1+size Ts+mxl0) (map OK τs) 
  wt_start P C Ts mxl0 τs 
  (pc < size is. P,Tr,mxs,size is,xt  is!pc,pc :: τs)"

― ‹A program is welltyped if it is wellformed and all methods are welltyped›
definition wf_jvm_prog_phi :: "tyP  'addr jvm_prog  bool" ("wf'_jvm'_prog⇘_")
where
  "wf_jvm_progΦ 
    wf_prog (λP C (M,Ts,Tr,(mxs,mxl0,is,xt)). 
      wt_method P C Ts Tr mxs mxl0 is xt (Φ C M))"

definition wf_jvm_prog :: "'addr jvm_prog  bool"
where
  "wf_jvm_prog P  Φ. wf_jvm_progΦ P"

lemma wt_jvm_progD:
  "wf_jvm_progΦ P  wt. wf_prog wt P"
(*<*) by (unfold wf_jvm_prog_phi_def, blast) (*>*)

lemma wt_jvm_prog_impl_wt_instr:
  " wf_jvm_progΦ P; 
      P  C sees M:Ts  T = (mxs,mxl0,ins,xt) in C; pc < size ins  
   P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M"
(*<*)
  apply (unfold wf_jvm_prog_phi_def)
  apply (drule (1) sees_wf_mdecl)
  apply (simp add: wf_mdecl_def wt_method_def)
  done
(*>*)

lemma wt_jvm_prog_impl_wt_start:
  " wf_jvm_progΦ P; 
     P  C sees M:Ts  T = (mxs,mxl0,ins,xt) in C   
  0 < size ins  wt_start P C Ts mxl0 (Φ C M)"
(*<*)
  apply (unfold wf_jvm_prog_phi_def)
  apply (drule (1) sees_wf_mdecl)
  apply (simp add: wf_mdecl_def wt_method_def)
  done
(*>*)

end

Theory BVConform

(*  Title:      JinjaThreads/BV/BVConform.thy
    Author:     Cornelia Pusch, Gerwin Klein, Andreas Lochbihler

The invariant for the type safety proof.
*)

section ‹BV Type Safety Invariant›

theory BVConform
imports
  BVSpec
  "../JVM/JVMExec"
begin

context JVM_heap_base begin

definition confT :: "'c prog  'heap  'addr val  ty err  bool"
    ("_,_  _ :≤ _" [51,51,51,51] 50)
where
  "P,h  v :≤ E  case E of Err  True | OK T  P,h  v :≤ T"

notation (ASCII) 
  confT  ("_,_ |- _ :<=T _" [51,51,51,51] 50)

abbreviation confTs :: "'c prog  'heap  'addr val list  tyl  bool"
  ("_,_  _ [:≤] _" [51,51,51,51] 50)
where
  "P,h  vs [:≤] Ts  list_all2 (confT P h) vs Ts"

notation (ASCII)
  confTs  ("_,_ |- _ [:<=T] _" [51,51,51,51] 50)

definition conf_f :: "'addr jvm_prog  'heap  tyi  'addr bytecode  'addr frame  bool"
where
  "conf_f P h  λ(ST,LT) is (stk,loc,C,M,pc). P,h  stk [:≤] ST  P,h  loc [:≤] LT  pc < size is"

primrec conf_fs :: "['addr jvm_prog,'heap,tyP,mname,nat,ty,'addr frame list]  bool"
where
  "conf_fs P h Φ M0 n0 T0 [] = True"

| "conf_fs P h Φ M0 n0 T0 (f#frs) =
  (let (stk,loc,C,M,pc) = f in
  (ST LT Ts T mxs mxl0 is xt.
    Φ C M ! pc = Some (ST,LT)  
    (P  C sees M:Ts  T = (mxs,mxl0,is,xt) in C) 
    (Ts' T' D m D'.  
       is!pc = (Invoke M0 n0)  class_type_of' (ST!n0) = D  P  D sees M0:Ts'  T' = m in D'  P  T0  T') 
    conf_f P h (ST, LT) is f  conf_fs P h Φ M (size Ts) T frs))"

primrec conf_xcp :: "'addr jvm_prog  'heap  'addr option  'addr instr  bool" where
  "conf_xcp P h None i = True"
| "conf_xcp P h a   i = (D. typeof_addr h a = Class_type D  P  D * Throwable 
                               (D'. P  D * D'  is_relevant_class i P D'))"

end

context JVM_heap_conf_base begin

definition correct_state :: "[tyP,'thread_id,('addr, 'heap) jvm_state]  bool"
where
  "correct_state Φ t  λ(xp,h,frs).
        P,h  t √t  hconf h  preallocated h 
        (case frs of
             []  True
             | (f#fs)  
             (let (stk,loc,C,M,pc) = f
              in Ts T mxs mxl0 is xt τ.
                    (P  C sees M:TsT = (mxs,mxl0,is,xt) in C) 
                    Φ C M ! pc = Some τ 
                    conf_f P h τ is f  conf_fs P h Φ M (size Ts) T fs 
                    conf_xcp P h xp (is ! pc) ))"

notation
  correct_state  ("_  _:_ "  [61,0,0] 61)

notation (ASCII)
  correct_state  ("_ |- _:_ [ok]"  [61,0,0] 61)

end

context JVM_heap_base begin

lemma conf_f_def2:
  "conf_f P h (ST,LT) is (stk,loc,C,M,pc) 
  P,h  stk [:≤] ST  P,h  loc [:≤] LT  pc < size is"
  by (simp add: conf_f_def)

subsection ‹Values and ⊤›

lemma confT_Err [iff]: "P,h  x :≤ Err" 
  by (simp add: confT_def)

lemma confT_OK [iff]:  "P,h  x :≤ OK T = (P,h  x :≤ T)"
  by (simp add: confT_def)

lemma confT_cases:
  "P,h  x :≤ X = (X = Err  (T. X = OK T  P,h  x :≤ T))"
  by (cases X) auto

lemma confT_widen [intro?, trans]:
  " P,h  x :≤ T; P  T  T'   P,h  x :≤ T'"
  by (cases T', auto intro: conf_widen)

end

context JVM_heap begin

lemma confT_hext [intro?, trans]:
  " P,h  x :≤ T; h  h'   P,h'  x :≤ T"
  by (cases T) (blast intro: conf_hext)+

end

subsection ‹Stack and Registers›

context JVM_heap_base begin

lemma confTs_Cons1 [iff]:
  "P,h  x # xs [:≤] Ts = (z zs. Ts = z # zs  P,h  x :≤ z  list_all2 (confT P h) xs zs)"
by(rule list_all2_Cons1)

lemma confTs_confT_sup:
  " P,h  loc [:≤] LT; n < size LT; LT!n = OK T; P  T  T'  
   P,h  (loc!n) :≤ T'"
  apply (frule list_all2_lengthD)
  apply (drule list_all2_nthD, simp)
  apply simp
  apply (erule conf_widen, assumption+)
  done

lemma confTs_widen [intro?, trans]:
  "P,h  loc [:≤] LT  P  LT [≤] LT'  P,h  loc [:≤] LT'"
  by (rule list_all2_trans, rule confT_widen)

lemma confTs_map [iff]:
  "(P,h  vs [:≤] map OK Ts) = (P,h  vs [:≤] Ts)"
  by (induct Ts arbitrary: vs) (auto simp add: list_all2_Cons2)

lemma (in -) reg_widen_Err:
  "(P  replicate n Err [≤] LT) = (LT = replicate n Err)"
  by (induct n arbitrary: LT) (auto simp add: list_all2_Cons1)

declare reg_widen_Err [iff]

lemma confTs_Err [iff]:
  "P,h  replicate n v [:≤] replicate n Err"
  by (induct n) auto

end

context JVM_heap begin

lemma confTs_hext [intro?]:
  "P,h  loc [:≤] LT  h  h'  P,h'  loc [:≤] LT"
  by (fast elim: list_all2_mono confT_hext)    
  
subsection ‹correct-frames›

declare fun_upd_apply[simp del]

lemma conf_f_hext:
  " conf_f P h Φ M f; h  h'   conf_f P h' Φ M f"
by(cases f, cases Φ, auto simp add: conf_f_def intro: confs_hext confTs_hext)

lemma conf_fs_hext:
  " conf_fs P h Φ M n Tr frs; h  h'   conf_fs P h' Φ M n Tr frs"
apply (induct frs arbitrary: M n Tr)
 apply simp
apply clarify
apply (simp (no_asm_use))
apply clarify
apply (unfold conf_f_def)
apply (simp (no_asm_use) split: if_split_asm)
apply (fast elim!: confs_hext confTs_hext)+
done

declare fun_upd_apply[simp]

lemma conf_xcp_hext:
  " conf_xcp P h xcp i; h  h'   conf_xcp P h' xcp i"
by(cases xcp)(auto elim: typeof_addr_hext_mono)

end

context JVM_heap_conf_base begin

lemmas defs1 = correct_state_def conf_f_def wt_instr_def eff_def norm_eff_def app_def xcpt_app_def

lemma correct_state_impl_Some_method:
  "Φ  t: (None, h, (stk,loc,C,M,pc)#frs) 
   m Ts T. P  C sees M:TsT = m in C"
  by(fastforce simp add: defs1)

end

context JVM_heap_conf_base' begin

lemma correct_state_hext_mono:
  " Φ  t: (xcp, h, frs) ; h  h'; hconf h'   Φ  t: (xcp, h', frs) "
unfolding correct_state_def
by(fastforce elim: tconf_hext_mono preallocated_hext conf_f_hext conf_fs_hext conf_xcp_hext split: list.split)

end

end

Theory BVSpecTypeSafe

(*  Title:      JinjaThreads/BV/BVSpecTypeSafe.thy
    Author:     Cornelia Pusch, Gerwin Klein, Andreas Lochbihler
*)

section ‹BV Type Safety Proof \label{sec:BVSpecTypeSafe}›

theory BVSpecTypeSafe
imports
  BVConform
  "../Common/ExternalCallWF"
begin

declare listE_length [simp del]

text ‹
  This theory contains proof that the specification of the bytecode
  verifier only admits type safe programs.  
›

subsection ‹Preliminaries›

text ‹
  Simp and intro setup for the type safety proof:
›
context JVM_heap_conf_base begin

lemmas widen_rules [intro] = conf_widen confT_widen confs_widens confTs_widen

end
  
subsection ‹Exception Handling›


text ‹
  For the Invoke› instruction the BV has checked all handlers
  that guard the current pc›.
›
lemma Invoke_handlers:
  "match_ex_table P C pc xt = Some (pc',d')  
  (f,t,D,h,d)  set (relevant_entries P (Invoke n M) pc xt). 
   (case D of None  True | Some D'  P  C * D')  pc  {f..<t}  pc' = h  d' = d"
  by (induct xt) (auto simp add: relevant_entries_def matches_ex_entry_def 
                                 is_relevant_entry_def split: if_split_asm)

lemma match_is_relevant:
  assumes rv: "D'. P  D * D'  is_relevant_class (ins ! i) P D'"
  assumes match: "match_ex_table P D pc xt = Some (pc',d')"
  shows "(f,t,D',h,d)  set (relevant_entries P (ins ! i) pc xt). (case D' of None  True | Some D''  P  D * D'')  pc  {f..<t}  pc' = h  d' = d"
using rv match
by(fastforce simp add: relevant_entries_def is_relevant_entry_def matches_ex_entry_def dest: match_ex_table_SomeD)


context JVM_heap_conf_base begin

lemma exception_step_conform:
  fixes σ' :: "('addr, 'heap) jvm_state"
  assumes wtp: "wf_jvm_progΦ P"
  assumes correct: "Φ  t:(xcp, h, fr # frs) "
  shows "Φ  t:exception_step P xcp h fr frs "
proof -
  obtain stk loc C M pc where fr: "fr = (stk, loc, C, M, pc)" by(cases fr)
  from correct obtain Ts T mxs mxl0 ins xt 
    where meth: "P  C sees M:Ts  T = (mxs,mxl0,ins,xt) in C"
    by (simp add: correct_state_def fr) blast

  from correct meth fr obtain D 
    where hxcp: "typeof_addr h xcp = Class_type D" and DsubThrowable: "P  D * Throwable"
    and rv: "D'. P  D * D'  is_relevant_class (instrs_of P C M ! pc) P D'"
    by(fastforce simp add: correct_state_def dest: sees_method_fun)
  
  from meth have [simp]: "ex_table_of P C M = xt" by simp

  from correct have tconf: "P,h  t √t" by(simp add: correct_state_def)

  show ?thesis
  proof(cases "match_ex_table P D pc xt")
    case None
    with correct fr meth hxcp show ?thesis
      by(fastforce simp add: correct_state_def cname_of_def split: list.split)
  next
    case (Some pc_d)
    then obtain pc' d' where pcd: "pc_d = (pc', d')"
      and match: "match_ex_table P D pc xt = Some (pc',d')" by (cases pc_d) auto
    from match_is_relevant[OF rv match] meth obtain f t D'
      where rv: "(f, t, D', pc', d')  set (relevant_entries P (ins ! pc) pc xt)"
      and DsubD': "(case D' of None  True | Some D''  P  D * D'')" and pc: "pc  {f..<t}" by(auto)

    from correct meth obtain ST LT
      where h_ok:  "hconf h"
      and Φ_pc: "Φ C M ! pc = Some (ST, LT)"
      and frame:  "conf_f P h (ST,LT) ins (stk,loc,C,M,pc)"
      and frames: "conf_fs P h Φ M (size Ts) T frs"
      and preh: "preallocated h"
      unfolding correct_state_def fr by(auto dest: sees_method_fun)

    from frame obtain stk: "P,h  stk [:≤] ST"
      and loc: "P,h  loc [:≤] LT" and pc:  "pc < size ins" 
      by (unfold conf_f_def) auto
    
    from stk have [simp]: "size stk = size ST" ..

    from wtp meth correct fr have wt: "P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M"
      by (auto simp add: correct_state_def conf_f_def
                   dest: sees_method_fun
                   elim!: wt_jvm_prog_impl_wt_instr)

    from wt Φ_pc have
      eff: "(pc', s')set (xcpt_eff (ins!pc) P pc (ST,LT) xt).
             pc' < size ins  P  s' ≤' Φ C M!pc'"
      by (auto simp add: defs1)

    let ?stk' = "Addr xcp # drop (length stk - d') stk"
    let ?f = "(?stk', loc, C, M, pc')"

    have conf: "P,h  Addr xcp :≤ Class (case D' of None  Throwable | Some D''  D'')"
      using DsubD' hxcp DsubThrowable by(auto simp add: conf_def)

    obtain ST' LT' where
      Φ_pc': "Φ C M ! pc' = Some (ST', LT')" and
      pc':   "pc' < size ins" and
      less:  "P  (Class D # drop (size ST - d') ST, LT) i (ST', LT')"
    proof(cases D')
      case Some
      thus ?thesis using eff rv DsubD' conf that
        by(fastforce simp add: xcpt_eff_def sup_state_opt_any_Some intro: widen_trans[OF widen_subcls])
    next
      case None
      with that eff rv conf DsubThrowable show ?thesis
        by(fastforce simp add: xcpt_eff_def sup_state_opt_any_Some intro: widen_trans[OF widen_subcls])
    qed

    with conf loc stk hxcp have "conf_f P h (ST',LT') ins ?f" 
      by (auto simp add: defs1 conf_def intro: list_all2_dropI)

    with meth h_ok frames Φ_pc' fr match hxcp tconf preh
    show ?thesis unfolding correct_state_def
      by(fastforce dest: sees_method_fun simp add: cname_of_def)
  qed
qed

end

subsection ‹Single Instructions›

text ‹
  In this subsection we prove for each single (welltyped) instruction
  that the state after execution of the instruction still conforms.
  Since we have already handled raised exceptions above, we can now assume that
  no exception has been raised in this step.
›

context JVM_conf_read begin

declare defs1 [simp]

lemma Invoke_correct: 
  fixes σ' :: "('addr, 'heap) jvm_state"
  assumes wtprog: "wf_jvm_progΦ P"
  assumes meth_C: "P  C sees M:TsT=(mxs,mxl0,ins,xt) in C"
  assumes ins:    "ins ! pc = Invoke M' n"
  assumes wti:    "P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M"
  assumes approx: "Φ  t:(None, h, (stk,loc,C,M,pc)#frs)"
  assumes exec: "(tas, σ)  exec_instr (ins!pc) P t h stk loc C M pc frs"
  shows "Φ  t:σ "
proof -
  note split_paired_Ex [simp del]
  
  from wtprog obtain wfmb where wfprog: "wf_prog wfmb P" 
    by (simp add: wf_jvm_prog_phi_def)
      
  from ins meth_C approx obtain ST LT where
    heap_ok: "hconf h" and
    tconf:   "P,h  t √t" and
    Φ_pc:    "Φ C M!pc = Some (ST,LT)" and
    frame:   "conf_f P h (ST,LT) ins (stk,loc,C,M,pc)" and
    frames:  "conf_fs P h Φ M (size Ts) T frs" and
    preh:    "preallocated h"
    by (fastforce dest: sees_method_fun)

  from ins wti Φ_pc
  have n: "n < size ST" by simp
  
  show ?thesis
  proof(cases "stk!n = Null")
    case True
    with ins heap_ok Φ_pc frame frames exec meth_C tconf preh show ?thesis
      by(fastforce elim: wf_preallocatedE[OF wfprog, where C=NullPointer])
  next
    case False
    note Null = this
    have NT: "ST!n  NT"
    proof
      assume "ST!n = NT"
      moreover from frame have "P,h  stk [:≤] ST" by simp
      with n have "P,h  stk!n :≤ ST!n" by (simp add: list_all2_conv_all_nth)
      ultimately have "stk!n = Null" by simp
      with Null show False by contradiction
    qed

    from frame obtain 
      stk: "P,h  stk [:≤] ST" and
      loc: "P,h  loc [:≤] LT" by simp

    from NT ins wti Φ_pc have pc': "pc+1 < size ins" by simp

    from NT ins wti Φ_pc obtain ST' LT'
      where pc': "pc+1 < size ins"
      and Φ': "Φ C M ! (pc+1) = Some (ST', LT')"
      and LT': "P  LT [≤] LT'"
      by(auto simp add: neq_Nil_conv sup_state_opt_any_Some split: if_split_asm)
    with NT ins wti Φ_pc obtain D D' TTs TT m
      where D: "class_type_of' (ST!n) = D"
      and m_D: "P  D sees M': TTsTT = m in D'"
      and Ts:  "P  rev (take n ST) [≤] TTs"
      and ST': "P  (TT # drop (n+1) ST) [≤] ST'" 
      by(auto)

    from n stk D have "P,h  stk!n :≤ ST ! n"
      by (auto simp add: list_all2_conv_all_nth)
      
    from P,h  stk!n :≤ ST ! n Null D
    obtain U a where
      Addr:   "stk!n = Addr a" and
      obj:    "typeof_addr h a = Some U" and
      UsubSTn: "P  ty_of_htype U  ST ! n"
      by(cases "stk ! n")(auto simp add: conf_def widen_Class)

    from D UsubSTn obtain C' where
      C': "class_type_of' (ty_of_htype U) = C'" and C'subD: "P  C' * D"
      by(rule widen_is_class_type_of) simp

    with wfprog m_D
    obtain Ts' T' D'' meth' where
      m_C': "P  C' sees M': Ts'T' = meth' in D''" and
      T':   "P  T'  TT" and
      Ts':  "P  TTs [≤] Ts'" 
      by (auto dest: sees_method_mono)

    from Ts n have [simp]: "size TTs = n" 
      by (auto dest: list_all2_lengthD simp: min_def)
    with Ts' have [simp]: "size Ts' = n" 
      by (auto dest: list_all2_lengthD)

    from m_C' wfprog
    obtain mD'': "P  D'' sees M':Ts'T'=meth' in D''"
      by (fast dest: sees_method_idemp)

    { fix mxs' mxl' ins' xt'
      assume [simp]: "meth' = (mxs', mxl', ins', xt')"
      let ?loc' = "Addr a # rev (take n stk) @ replicate mxl' undefined_value"
      let ?f' = "([], ?loc', D'', M', 0)"
      let ?f  = "(stk, loc, C, M, pc)"
      
      from Addr obj m_C' ins meth_C exec C' False
      have s': "σ = (None, h, ?f' # ?f # frs)" by(auto split: if_split_asm)
      
      moreover 
      from wtprog mD''
      obtain start: "wt_start P D'' Ts' mxl' (Φ D'' M')" and ins': "ins'  []"
        by (auto dest: wt_jvm_prog_impl_wt_start)
      then obtain LT0 where LT0: "Φ D'' M' ! 0 = Some ([], LT0)"
        by (clarsimp simp add: wt_start_def defs1 sup_state_opt_any_Some)
      moreover
      have "conf_f P h ([], LT0) ins' ?f'"
      proof -
        let ?LT = "OK (Class D'') # (map OK Ts') @ (replicate mxl' Err)"
        
        from stk have "P,h  take n stk [:≤] take n ST" ..
        hence "P,h  rev (take n stk) [:≤] rev (take n ST)" by simp
        also note Ts also note Ts' finally
        have "P,h  rev (take n stk) [:≤] map OK Ts'" by simp 
        also
        have "P,h  replicate mxl' undefined_value [:≤] replicate mxl' Err" by simp
        also from m_C' have "P  C' * D''" by (rule sees_method_decl_above)
        from obj heap_ok have "is_htype P U" by (rule typeof_addr_is_type)
        with C' have "P  ty_of_htype U  Class C'" 
          by(cases U)(simp_all add: widen_array_object)
        with P  C' * D'' obj C' have "P,h  Addr a :≤ Class D''"
          by (auto simp add: conf_def intro: widen_trans)
        ultimately
        have "P,h  ?loc' [:≤] ?LT" by simp
        also from start LT0 have "P   [≤] LT0" by (simp add: wt_start_def)
        finally have "P,h  ?loc' [:≤] LT0" .
        thus ?thesis using ins' by simp
      qed
      ultimately have ?thesis using s' Φ_pc approx meth_C m_D T' ins D tconf C' mD''
        by (fastforce dest: sees_method_fun [of _ C]) }
    moreover
    { assume [simp]: "meth' = Native"
      with wfprog m_C' have "D''M'(Ts') :: T'" by(simp add: sees_wf_native)
      with C' m_C' have nec: "is_native P U M'" by(auto intro: is_native.intros)

      from ins n Addr obj exec m_C' C'
      obtain va h' tas' where va: "(tas', va, h')  red_external_aggr P t a M' (rev (take n stk)) h"
        and σ: "σ = extRet2JVM n h' stk loc C M pc frs va" by(auto)
      from va nec obj have hext: "h  h'" by(auto intro: red_external_aggr_hext)
      with frames have frames': "conf_fs P h' Φ M (length Ts) T frs" by(rule conf_fs_hext)
      from preh hext have preh': "preallocated h'" by(rule preallocated_hext)      
      from va nec obj tconf have tconf': "P,h'  t √t"
        by(auto dest: red_external_aggr_preserves_tconf)
      from hext obj have obj': "typeof_addr h' a = U" by(rule typeof_addr_hext_mono)

      from stk have "P,h  take n stk [:≤] take n ST" by(rule list_all2_takeI)
      then obtain Us where "map typeofh (take n stk) = map Some Us" "P  Us [≤] take n ST"
        by(auto simp add: confs_conv_map)
      hence Us: "map typeofh (rev (take n stk)) = map Some (rev Us)" "P  rev Us [≤] rev (take n ST)"
        by- (simp only: rev_map[symmetric], simp)
      from P  rev Us [≤] rev (take n ST) Ts Ts'
      have "P  rev Us [≤] Ts'" by(blast intro: widens_trans)
      with obj ‹map typeofh (rev (take n stk)) = map Some (rev Us) C' m_C' 
      have wtext': "P,h  aM'(rev (take n stk)) : T'" by(simp add: external_WT'.intros)
      from va have va': "P,t  aM'(rev (take n stk)),h -tas'→ext va,h'"
        by(unfold WT_red_external_list_conv[OF wfprog wtext' tconf])
      with heap_ok wtext' tconf wfprog have heap_ok': "hconf h'" by(auto dest: external_call_hconf)

      have ?thesis
      proof(cases va)
        case (RetExc a')
        from frame hext have "conf_f P h' (ST, LT) ins (stk, loc, C, M, pc)" by(rule conf_f_hext)
        with σ tconf' heap_ok' meth_C Φ_pc frames' RetExc red_external_conf_extRet[OF wfprog va' wtext' heap_ok preh tconf] ins preh'
        show ?thesis by(fastforce simp add: conf_def widen_Class)
      next
        case RetStaySame
        from frame hext have "conf_f P h' (ST, LT) ins (stk, loc, C, M, pc)" by(rule conf_f_hext)
        with σ heap_ok' meth_C Φ_pc RetStaySame frames' tconf' preh' show ?thesis by fastforce
      next
        case (RetVal v)
        with σ have σ: "σ = (None, h', (v # drop (n+1) stk, loc, C, M, pc+1) # frs)" by simp
        from heap_ok wtext' va' RetVal preh tconf have "P,h'  v :≤ T'"
          by(auto dest: red_external_conf_extRet[OF wfprog])
        from stk have "P,h  drop (n + 1) stk [:≤] drop (n+1) ST" by(rule list_all2_dropI)
        hence "P,h'  drop (n + 1) stk [:≤] drop (n+1) ST" using hext by(rule confs_hext)
        with P,h'  v :≤ T' have "P,h'  v # drop (n + 1) stk [:≤] T' # drop (n+1) ST"
          by(auto simp add: conf_def intro: widen_trans)
        also
        with NT ins wti Φ_pc Φ' nec False D m_D T'
        have "P  (T' # drop (n + 1) ST) [≤] ST'"
          by(auto dest: sees_method_fun intro: widen_trans)
        also from loc hext have "P,h'  loc [:≤] LT" by(rule confTs_hext)
        hence "P,h'  loc [:≤] LT'" using LT' by(rule confTs_widen)
        ultimately show ?thesis using hconf h' σ meth_C Φ' pc' frames' tconf' preh' by fastforce
      qed }
    ultimately show ?thesis by(cases meth') auto
  qed
qed

declare list_all2_Cons2 [iff]

lemma Return_correct:
  assumes wt_prog: "wf_jvm_progΦ P"
  assumes meth: "P  C sees M:TsT=(mxs,mxl0,ins,xt) in C"
  assumes ins: "ins ! pc = Return"
  assumes wt: "P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M"
  assumes correct: "Φ  t:(None, h, (stk,loc,C,M,pc)#frs)"
  assumes s': "(tas, σ')  exec P t (None, h, (stk,loc,C,M,pc)#frs)"
  shows "Φ  t:σ'"
proof -
  from wt_prog 
  obtain wfmb where wf: "wf_prog wfmb P" by (simp add: wf_jvm_prog_phi_def)

  from meth ins s' correct
  have "frs = []  ?thesis" by (simp add: correct_state_def)
  moreover
  { fix f frs' assume frs': "frs = f#frs'"
    moreover obtain stk' loc' C' M' pc' where 
      f: "f = (stk',loc',C',M',pc')" by (cases f)
    moreover note meth ins s'
    ultimately
    have σ':
      "σ' = (None,h,(hd stk#(drop (1+size Ts) stk'),loc',C',M',pc'+1)#frs')"
      (is "σ' = (None,h,?f'#frs')")
      by simp
    
    from correct meth
    obtain ST LT where
      h_ok:   "hconf h" and
      tconf: "P,h  t √t" and
      Φ_pc: "Φ C M ! pc = Some (ST, LT)" and
      frame:  "conf_f P h (ST, LT) ins (stk,loc,C,M,pc)" and
      frames: "conf_fs P h Φ M (size Ts) T frs" and
      preh: "preallocated h"
      by (auto dest: sees_method_fun)

    from Φ_pc ins wt
    obtain U ST0 where "ST = U # ST0" "P  U  T"
      by (simp add: wt_instr_def app_def) blast    
    with wf frame 
    have hd_stk: "P,h  hd stk :≤ T" by (auto simp add: conf_f_def)

    from f frs' frames
    obtain ST' LT' Ts'' T'' mxs' mxl0' ins' xt' Ts' T' where
      Φ': "Φ C' M' ! pc' = Some (ST', LT')" and
      meth_C':  "P  C' sees M':Ts''T''=(mxs',mxl0',ins',xt') in C'" and
      ins': "ins' ! pc' = Invoke M (size Ts)" and
      D: "D m D'. class_type_of' (ST' ! (size Ts)) = Some D  P  D sees M: Ts'T' = m in D'" and
      T': "P  T  T'" and
      frame':   "conf_f P h (ST',LT') ins' f" and
      conf_fs:  "conf_fs P h Φ M' (size Ts'') T'' frs'"
      by clarsimp blast

    from f frame' obtain
      stk': "P,h  stk' [:≤] ST'" and
      loc': "P,h  loc' [:≤] LT'" and
      pc':  "pc' < size ins'"
      by (simp add: conf_f_def)
    
    from wt_prog meth_C' pc'  
    have wti: "P,T'',mxs',size ins',xt'  ins'!pc',pc' :: Φ C' M'"
      by (rule wt_jvm_prog_impl_wt_instr)

    obtain aTs ST'' LT'' where
      Φ_suc:   "Φ C' M' ! Suc pc' = Some (ST'', LT'')" and
      less:    "P  (T' # drop (size Ts+1) ST', LT') i (ST'', LT'')" and
      suc_pc': "Suc pc' < size ins'"
      using ins' Φ' D T' wti
      by(fastforce simp add: sup_state_opt_any_Some split: if_split_asm)

    from hd_stk T' have hd_stk': "P,h  hd stk :≤ T'"  ..
        
    have frame'':
      "conf_f P h (ST'',LT'') ins' ?f'" 
    proof -
      from stk'
      have "P,h  drop (1+size Ts) stk' [:≤] drop (1+size Ts) ST'" ..
      moreover
      with hd_stk' less
      have "P,h  hd stk # drop (1+size Ts) stk' [:≤] ST''" by auto
      moreover
      from wf loc' less have "P,h  loc' [:≤] LT''" by auto
      moreover note suc_pc' 
      ultimately show ?thesis by (simp add: conf_f_def)
    qed

    with σ' frs' f meth h_ok hd_stk Φ_suc frames meth_C' Φ'  tconf preh
    have ?thesis by (fastforce dest: sees_method_fun [of _ C'])
  }
  ultimately
  show ?thesis by (cases frs) blast+
qed

declare sup_state_opt_any_Some [iff]
declare not_Err_eq [iff] 

lemma Load_correct:
" wf_prog wt P;
    P  C sees M:TsT=(mxs,mxl0,ins,xt) in C; 
    ins!pc = Load idx; 
    P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M; 
    Φ  t:(None, h, (stk,loc,C,M,pc)#frs) ;
    (tas, σ')  exec P t (None, h, (stk,loc,C,M,pc)#frs) 
 Φ  t:σ' "
  by (fastforce dest: sees_method_fun [of _ C] elim!: confTs_confT_sup)

declare [[simproc del: list_to_set_comprehension]]

lemma Store_correct:
" wf_prog wt P;
  P  C sees M:TsT=(mxs,mxl0,ins,xt) in C;
  ins!pc = Store idx;
  P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M;
  Φ  t:(None, h, (stk,loc,C,M,pc)#frs);
  (tas, σ')  exec P t (None, h, (stk,loc,C,M,pc)#frs) 
 Φ  t:σ'"
  apply clarsimp 
  apply (drule (1) sees_method_fun)
  apply clarsimp
  apply (blast intro!: list_all2_update_cong)
  done

lemma Push_correct:
" wf_prog wt P;
    P  C sees M:TsT=(mxs,mxl0,ins,xt) in C; 
    ins!pc = Push v;
    P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M; 
    Φ  t:(None, h, (stk,loc,C,M,pc)#frs); 
    (tas, σ')  exec P t (None, h, (stk,loc,C,M,pc)#frs) 
 Φ  t:σ'" 
  apply clarsimp 
  apply (drule (1) sees_method_fun)
  apply clarsimp
  apply (blast dest: typeof_lit_conf)
  done

declare [[simproc add: list_to_set_comprehension]]

lemma Checkcast_correct:
" wf_jvm_progΦ P;
    P  C sees M:TsT=(mxs,mxl0,ins,xt) in C; 
    ins!pc = Checkcast D; 
    P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M; 
    Φ  t:(None, h, (stk,loc,C,M,pc)#frs);
    (tas, σ)  exec_instr (ins!pc) P t h stk loc C M pc frs  
 Φ  t:σ "
using wf_preallocatedD[of "λP C (M, Ts, Tr, mxs, mxl0, is, xt). wt_method P C Ts Tr mxs mxl0 is xt (Φ C M)" P h ClassCast]
apply (clarsimp simp add: wf_jvm_prog_phi_def split: if_split_asm)
 apply(drule (1) sees_method_fun)
 apply(fastforce simp add: conf_def intro: widen_trans)
apply (drule (1) sees_method_fun)
apply(fastforce simp add: conf_def intro: widen_trans)
done

lemma Instanceof_correct:
" wf_jvm_progΦ P;
    P  C sees M:TsT=(mxs,mxl0,ins,xt) in C; 
    ins!pc = Instanceof Ty; 
    P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M; 
    Φ  t:(None, h, (stk,loc,C,M,pc)#frs);
    (tas, σ)  exec_instr (ins!pc) P t h stk loc C M pc frs  
 Φ  t:σ "
  apply (clarsimp simp add: wf_jvm_prog_phi_def split: if_split_asm)
  apply (drule (1) sees_method_fun)
  apply fastforce
  done

declare split_paired_All [simp del]

end

lemma widens_Cons [iff]:
  "P  (T # Ts) [≤] Us = (z zs. Us = z # zs  P  T  z  P  Ts [≤] zs)"
by(rule list_all2_Cons1)

context heap_conf_base begin


end

context JVM_conf_read begin

lemma Getfield_correct:
  assumes wf: "wf_prog wt P"
  assumes mC: "P  C sees M:TsT=(mxs,mxl0,ins,xt) in C"
  assumes i:  "ins!pc = Getfield F D"
  assumes wt: "P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M"
  assumes cf: "Φ  t:(None, h, (stk,loc,C,M,pc)#frs)"
  assumes xc: "(tas, σ')  exec_instr (ins!pc) P t h stk loc C M pc frs"

  shows "Φ  t:σ'"
proof -
  from mC cf obtain ST LT where    
    "h√": "hconf h" and
    tconf: "P,h  t √t" and
    Φ: "Φ C M ! pc = Some (ST,LT)" and
    stk: "P,h  stk [:≤] ST" and loc: "P,h  loc [:≤] LT" and
    pc: "pc < size ins" and 
    fs: "conf_fs P h Φ M (size Ts) T frs" and
    preh: "preallocated h"
    by (fastforce dest: sees_method_fun)
       
  from i Φ wt obtain oT ST'' vT ST' LT' vT' fm where 
    oT: "P  oT  Class D" and
    ST: "ST = oT # ST''" and
    F:  "P  D sees F:vT (fm) in D" and
    pc': "pc+1 < size ins"  and
    Φ': "Φ C M ! (pc+1) = Some (vT'#ST', LT')" and
    ST': "P  ST'' [≤] ST'" and LT': "P  LT [≤] LT'" and  
    vT': "P  vT  vT'"
    by fastforce                       

  from stk ST obtain ref stk' where 
    stk': "stk = ref#stk'" and
    ref:  "P,h  ref :≤ oT" and
    ST'': "P,h  stk' [:≤] ST''"
    by auto

  show ?thesis
  proof(cases "ref = Null")
    case True
    with tconf "h√" i xc stk' mC fs Φ ST'' ref ST loc pc' 
      wf_preallocatedD[OF wf, of h NullPointer] preh
    show ?thesis by(fastforce)
  next
    case False
    from ref oT have "P,h  ref :≤ Class D" ..
    with False obtain a U' D' where a: "ref = Addr a"
      and h: "typeof_addr h a = Some U'"
      and U': "D' = class_type_of U'" and D': "P  D' * D"
      by (blast dest: non_npD2)

    { fix v
      assume read: "heap_read h a (CField D F) v"
      from D' F have has_field: "P  D' has F:vT (fm) in D"
        by (blast intro: has_field_mono has_visible_field)
      with h have "P,h  a@CField D F : vT" unfolding U' .. 
      with read have v: "P,h  v :≤ vT" using "h√"
        by(rule heap_read_conf)
      
      from ST'' ST' have "P,h  stk' [:≤] ST'" ..
      moreover
      from v vT' have "P,h  v :≤ vT'" by blast
      moreover
      from loc LT' have "P,h  loc [:≤] LT'" ..
      moreover
      note "h√" mC Φ' pc' v fs tconf preh
      ultimately have "Φ  t:(None, h, (v#stk',loc,C,M,pc+1)#frs) " by fastforce }
    with a h i mC stk' xc
    show ?thesis by auto
  qed
qed

lemma Putfield_correct:
  assumes wf: "wf_prog wt P"
  assumes mC: "P  C sees M:TsT=(mxs,mxl0,ins,xt) in C"
  assumes i:  "ins!pc = Putfield F D"
  assumes wt: "P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M"
  assumes cf: "Φ  t:(None, h, (stk,loc,C,M,pc)#frs)"
  assumes xc: "(tas, σ')  exec_instr (ins!pc) P t h stk loc C M pc frs"
  shows "Φ  t:σ' "
proof -
  from mC cf obtain ST LT where    
    "h√": "hconf h" and    
    tconf: "P,h  t √t" and
    Φ: "Φ C M ! pc = Some (ST,LT)" and
    stk: "P,h  stk [:≤] ST" and loc: "P,h  loc [:≤] LT" and
    pc: "pc < size ins" and 
    fs: "conf_fs P h Φ M (size Ts) T frs" and
    preh: "preallocated h"
    by (fastforce dest: sees_method_fun)
  
  from i Φ wt obtain vT vT' oT ST'' ST' LT' fm where 
    ST: "ST = vT # oT # ST''" and
    field: "P  D sees F:vT' (fm) in D" and
    oT: "P  oT  Class D" and vT: "P  vT  vT'" and
    pc': "pc+1 < size ins" and 
    Φ': "Φ C M!(pc+1) = Some (ST',LT')" and
    ST': "P  ST'' [≤] ST'" and LT': "P  LT [≤] LT'"
    by clarsimp

  from stk ST obtain v ref stk' where 
    stk': "stk = v#ref#stk'" and
    v:    "P,h  v :≤ vT" and 
    ref:  "P,h  ref :≤ oT" and
    ST'': "P,h  stk' [:≤] ST''"
    by auto

  show ?thesis
  proof(cases "ref = Null")
    case True
    with tconf "h√" i xc stk' mC fs Φ ST'' ref ST loc pc' v
      wf_preallocatedD[OF wf, of h NullPointer] preh
    show ?thesis by(fastforce)
  next
    case False
    from ref oT have "P,h  ref :≤ Class D" ..
    with False obtain a U' D' where 
      a: "ref = Addr a" and h: "typeof_addr h a = Some U'"
      and U': "D' = class_type_of U'" and D': "P  D' * D"
      by (blast dest: non_npD2)
    
    from v vT have vT': "P,h  v :≤ vT'" ..
    
    from field D' have has_field: "P  D' has F:vT' (fm) in D"
      by (blast intro: has_field_mono has_visible_field)
    with h have al: "P,h  a@CField D F : vT'" unfolding U' ..
    let ?f' = "(stk',loc,C,M,pc+1)"

    { fix h'
      assume "write": "heap_write h a (CField D F) v h'"
      hence hext: "h  h'" by(rule hext_heap_write)
      with preh have "preallocated h'" by(rule preallocated_hext)
      moreover
      from "write" "h√" al vT' have "hconf h'" by(rule hconf_heap_write_mono)
      moreover
      from ST'' ST' have "P,h  stk' [:≤] ST'" ..
      from this hext have "P,h'  stk' [:≤] ST'" by (rule confs_hext)
      moreover
      from loc LT' have "P,h  loc [:≤] LT'" ..
      from this hext have "P,h'  loc [:≤] LT'" by (rule confTs_hext)
      moreover
      from fs hext
      have "conf_fs P h' Φ M (size Ts) T frs" by (rule conf_fs_hext)
      moreover
      note mC Φ' pc' 
      moreover
      from tconf hext have "P,h'  t √t" by(rule tconf_hext_mono)
      ultimately have "Φ  t:(None, h', ?f'#frs) " by fastforce }
    with a h i mC stk' xc show ?thesis by(auto simp del: correct_state_def)
  qed
qed

lemma CAS_correct:
  assumes wf: "wf_prog wt P"
  assumes mC: "P  C sees M:TsT=(mxs,mxl0,ins,xt) in C"
  assumes i:  "ins!pc = CAS F D"
  assumes wt: "P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M"
  assumes cf: "Φ  t:(None, h, (stk,loc,C,M,pc)#frs)"
  assumes xc: "(tas, σ')  exec_instr (ins!pc) P t h stk loc C M pc frs"
  shows "Φ  t:σ' "
proof -
  from mC cf obtain ST LT where    
    "h√": "hconf h" and    
    tconf: "P,h  t √t" and
    Φ: "Φ C M ! pc = Some (ST,LT)" and
    stk: "P,h  stk [:≤] ST" and loc: "P,h  loc [:≤] LT" and
    pc: "pc < size ins" and 
    fs: "conf_fs P h Φ M (size Ts) T frs" and
    preh: "preallocated h"
    by (fastforce dest: sees_method_fun)
  
  from i Φ wt obtain T1 T2 T3 T' ST'' ST' LT' fm where 
    ST: "ST = T3 # T2 # T1 # ST''" and
    field: "P  D sees F:T' (fm) in D" and
    oT: "P  T1  Class D" and T2: "P  T2  T'" and T3: "P  T3  T'" and
    pc': "pc+1 < size ins" and 
    Φ': "Φ C M!(pc+1) = Some (Boolean # ST',LT')" and
    ST': "P  ST'' [≤] ST'" and LT': "P  LT [≤] LT'"
    by clarsimp

  from stk ST obtain v'' v' v stk' where 
    stk': "stk = v''#v'#v#stk'" and
    v:    "P,h  v :≤ T1" and 
    v':  "P,h  v' :≤ T2" and
    v'': "P,h  v'' :≤ T3" and
    ST'': "P,h  stk' [:≤] ST''"
    by auto

  show ?thesis
  proof(cases "v = Null")
    case True
    with tconf "h√" i xc stk' mC fs Φ ST'' v ST loc pc' v' v''
      wf_preallocatedD[OF wf, of h NullPointer] preh
    show ?thesis by(fastforce)
  next
    case False
    from v oT have "P,h  v :≤ Class D" ..
    with False obtain a U' D' where 
      a: "v = Addr a" and h: "typeof_addr h a = Some U'"
      and U': "D' = class_type_of U'" and D': "P  D' * D"
      by (blast dest: non_npD2)
    
    from v' T2 have vT': "P,h  v' :≤ T'" ..
    from v'' T3 have vT'': "P,h  v'' :≤ T'" ..
    
    from field D' have has_field: "P  D' has F:T' (fm) in D"
      by (blast intro: has_field_mono has_visible_field)
    with h have al: "P,h  a@CField D F : T'" unfolding U' ..

    from ST'' ST' have stk'': "P,h  stk' [:≤] ST'" ..
    from loc LT' have loc': "P,h  loc [:≤] LT'" ..
    { fix h'
      assume "write": "heap_write h a (CField D F) v'' h'"
      hence hext: "h  h'" by(rule hext_heap_write)
      with preh have "preallocated h'" by(rule preallocated_hext)
      moreover
      from "write" "h√" al vT'' have "hconf h'" by(rule hconf_heap_write_mono)
      moreover
      from stk'' hext have "P,h'  stk' [:≤] ST'" by (rule confs_hext)
      moreover
      from loc' hext have "P,h'  loc [:≤] LT'" by (rule confTs_hext)
      moreover
      from fs hext
      have "conf_fs P h' Φ M (size Ts) T frs" by (rule conf_fs_hext)
      moreover
      note mC Φ' pc' 
      moreover
      let ?f' = "(Bool True # stk',loc,C,M,pc+1)"
      from tconf hext have "P,h'  t √t" by(rule tconf_hext_mono)
      ultimately have "Φ  t:(None, h', ?f'#frs) " by fastforce 
    } moreover {
      let ?f' = "(Bool False # stk',loc,C,M,pc+1)"
      have "Φ  t:(None, h, ?f'#frs) " using tconf "h√" preh mC Φ' stk'' loc' pc' fs
        by fastforce
    } ultimately show ?thesis using a h i mC stk' xc by(auto simp del: correct_state_def)
  qed
qed

lemma New_correct:
  assumes wf:   "wf_prog wt P"
  assumes meth: "P  C sees M:TsT=(mxs,mxl0,ins,xt) in C"
  assumes ins:  "ins!pc = New X"
  assumes wt:   "P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M"
  assumes conf: "Φ  t:(None, h, (stk,loc,C,M,pc)#frs)"
  assumes no_x: "(tas, σ)  exec_instr (ins!pc) P t h stk loc C M pc frs"
  shows "Φ  t:σ "
proof - 
  from ins conf meth
  obtain ST LT where
    heap_ok: "hconf h" and
    tconf:   "P,h  t √t" and
    Φ_pc:    "Φ C M!pc = Some (ST,LT)" and
    frame:   "conf_f P h (ST,LT) ins (stk,loc,C,M,pc)" and
    frames:  "conf_fs P h Φ M (size Ts) T frs" and
    preh:    "preallocated h"
    by (auto dest: sees_method_fun)

  from Φ_pc ins wt
  obtain ST' LT' where
    is_class_X: "is_class P X" and
    mxs:       "size ST < mxs" and
    suc_pc:     "pc+1 < size ins" and
    Φ_suc:      "Φ C M!(pc+1) = Some (ST', LT')" and
    less:       "P  (Class X # ST, LT) i (ST', LT')"
    by auto
  show ?thesis
  proof(cases "allocate h (Class_type X) = {}")
    case True
    with frame frames tconf suc_pc no_x ins meth Φ_pc
      wf_preallocatedD[OF wf, of h OutOfMemory] preh is_class_X heap_ok
    show ?thesis
      by(fastforce intro: tconf_hext_mono confs_hext confTs_hext conf_fs_hext)
  next
    case False
    with ins meth no_x obtain h' oref 
      where new: "(h', oref)  allocate h (Class_type X)"
      and σ': "σ = (None, h', (Addr oref#stk,loc,C,M,pc+1)#frs)" (is "σ = (None, h', ?f # frs)")
      by auto

    from new have hext: "h  h'" by(rule hext_allocate)
    with preh have preh': "preallocated h'" by(rule preallocated_hext)
    from new heap_ok is_class_X have heap_ok': "hconf h'"
      by(auto intro: hconf_allocate_mono)

    with new is_class_X have h': "typeof_addr h' oref = Class_type X" by(auto dest: allocate_SomeD)
  
    note heap_ok' σ'
    moreover
    from frame less suc_pc wf h' hext
    have "conf_f P h' (ST', LT') ins ?f"
      apply (clarsimp simp add: fun_upd_apply conf_def split_beta)
      apply (auto intro: confs_hext confTs_hext)
      done
    moreover
    from frames hext have "conf_fs P h' Φ M (size Ts) T frs" by (rule conf_fs_hext)
    moreover from tconf hext have "P,h'  t √t" by(rule tconf_hext_mono)
    ultimately
    show ?thesis using meth Φ_suc preh' by fastforce
  qed
qed

lemma Goto_correct:
" wf_prog wt P; 
  P  C sees M:TsT=(mxs,mxl0,ins,xt) in C; 
  ins ! pc = Goto branch; 
  P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M; 
  Φ  t:(None, h, (stk,loc,C,M,pc)#frs); 
  (tas, σ')  exec P t (None, h, (stk,loc,C,M,pc)#frs) 
 Φ  t:σ' "
apply clarsimp 
apply (drule (1) sees_method_fun)
apply fastforce
done

declare [[simproc del: list_to_set_comprehension]]

lemma IfFalse_correct:
" wf_prog wt P; 
  P  C sees M:TsT=(mxs,mxl0,ins,xt) in C; 
  ins ! pc = IfFalse branch; 
  P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M; 
  Φ  t:(None, h, (stk,loc,C,M,pc)#frs);
  (tas, σ')  exec P t (None, h, (stk,loc,C,M,pc)#frs) 
 Φ  t:σ'"
apply clarsimp
apply (drule (1) sees_method_fun)
apply fastforce
done

declare [[simproc add: list_to_set_comprehension]]

lemma BinOp_correct:
" wf_prog wt P; 
  P  C sees M:TsT=(mxs,mxl0,ins,xt) in C; 
  ins ! pc = BinOpInstr bop;
  P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M; 
  Φ  t:(None, h, (stk,loc,C,M,pc)#frs);
  (tas, σ')  exec P t (None, h, (stk,loc,C,M,pc)#frs) 
 Φ  t:σ'"
apply clarsimp
apply (drule (1) sees_method_fun)
apply(clarsimp simp add: conf_def)
apply(drule (2) WTrt_binop_widen_mono)
apply clarsimp
apply(frule (2) binop_progress)
apply(clarsimp split: sum.split_asm)
 apply(frule (5) binop_type)
 apply(fastforce intro: widen_trans simp add: conf_def)
apply(frule (5) binop_type)
apply(clarsimp simp add: conf_def)
apply(clarsimp simp add: widen_Class)
apply(fastforce intro: widen_trans dest: binop_relevant_class simp add: cname_of_def conf_def)
done

lemma Pop_correct:
" wf_prog wt P; 
  P  C sees M:TsT=(mxs,mxl0,ins,xt) in C; 
  ins ! pc = Pop;
  P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M; 
  Φ  t:(None, h, (stk,loc,C,M,pc)#frs);
  (tas, σ')  exec P t (None, h, (stk,loc,C,M,pc)#frs) 
 Φ  t:σ'"
apply clarsimp
apply (drule (1) sees_method_fun)
apply fastforce
done

lemma Dup_correct:
" wf_prog wt P; 
  P  C sees M:TsT=(mxs,mxl0,ins,xt) in C; 
  ins ! pc = Dup;
  P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M; 
  Φ  t:(None, h, (stk,loc,C,M,pc)#frs);
  (tas, σ')  exec P t (None, h, (stk,loc,C,M,pc)#frs) 
 Φ  t:σ'"
apply clarsimp
apply (drule (1) sees_method_fun)
apply fastforce
done

lemma Swap_correct:
" wf_prog wt P; 
  P  C sees M:TsT=(mxs,mxl0,ins,xt) in C; 
  ins ! pc = Swap;
  P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M; 
  Φ  t:(None, h, (stk,loc,C,M,pc)#frs);
  (tas, σ')  exec P t (None, h, (stk,loc,C,M,pc)#frs) 
 Φ  t:σ'"
apply clarsimp
apply (drule (1) sees_method_fun)
apply fastforce
done

declare [[simproc del: list_to_set_comprehension]]

lemma Throw_correct:
" wf_prog wt P; 
  P  C sees M:TsT=(mxs,mxl0,ins,xt) in C; 
  ins ! pc = ThrowExc; 
  P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M; 
  Φ  t:(None, h, (stk,loc,C,M,pc)#frs);
  (tas, σ')  exec_instr (ins!pc) P t h stk loc C M pc frs  
 Φ  t:σ'"
using wf_preallocatedD[of wt P h NullPointer]
apply(clarsimp)
apply(drule (1) sees_method_fun)
apply(auto)
  apply fastforce
 apply fastforce
apply(drule (1) non_npD)
apply fastforce+
done

declare [[simproc add: list_to_set_comprehension]]

lemma NewArray_correct:
  assumes wf:   "wf_prog wt P"
  assumes meth: "P  C sees M:TsT=(mxs,mxl0,ins,xt) in C"
  assumes ins:  "ins!pc = NewArray X"
  assumes wt:   "P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M"
  assumes conf: "Φ  t:(None, h, (stk,loc,C,M,pc)#frs)"
  assumes no_x: "(tas, σ)  exec_instr (ins!pc) P t h stk loc C M pc frs"
  shows "Φ  t:σ "
proof - 
  from ins conf meth
  obtain ST LT where
    heap_ok: "hconf h" and
    tconf: "P,h  t √t" and
    Φ_pc:    "Φ C M!pc = Some (ST,LT)" and
    stk: "P,h  stk [:≤] ST" and loc: "P,h  loc [:≤] LT" and
    pc: "pc < size ins" and 
    frame:   "conf_f P h (ST,LT) ins (stk,loc,C,M,pc)" and
    frames:  "conf_fs P h Φ M (size Ts) T frs" and
    preh:    "preallocated h"
    by (auto dest: sees_method_fun)

  from ins Φ_pc wt obtain ST'' X' ST' LT' where 
    ST: "ST = Integer # ST''" and
    pc': "pc+1 < size ins"  and
    Φ': "Φ C M ! (pc+1) = Some (X'#ST', LT')" and
    ST': "P  ST'' [≤] ST'" and LT': "P  LT [≤] LT'" and
    XX': "P  X⌊⌉  X'" and
    suc_pc:     "pc+1 < size ins" and
    is_type_X: "is_type P (X⌊⌉)"
    by(fastforce dest: Array_widen)

  from stk ST obtain si stk' where si: "stk = Intg si # stk'"
    by(auto simp add: conf_def)

  show ?thesis
  proof(cases "si <s 0  allocate h (Array_type X (nat (sint si))) = {}")
    case True
    with frame frames tconf heap_ok suc_pc no_x ins meth Φ_pc si preh
      wf_preallocatedD[OF wf, of h OutOfMemory] wf_preallocatedD[OF wf, of h NegativeArraySize]
    show ?thesis
      by(fastforce intro: tconf_hext_mono confs_hext confTs_hext conf_fs_hext split: if_split_asm)+
  next
    case False
    with ins meth si no_x obtain h' oref 
      where new: "(h', oref)  allocate h (Array_type X (nat (sint si)))"
      and σ': "σ = (None, h', (Addr oref#tl stk,loc,C,M,pc+1)#frs)" (is "σ = (None, h', ?f # frs)")
      by(auto split: if_split_asm)
    from new have hext: "h  h'" by(rule hext_allocate)
    with preh have preh': "preallocated h'" by(rule preallocated_hext)
    from new heap_ok is_type_X have heap_ok': "hconf h'" by(auto intro: hconf_allocate_mono)
    from False have si': "0 <=s si" by auto
    with new is_type_X have h': "typeof_addr h' oref = Array_type X (nat (sint si))" 
      by(auto dest: allocate_SomeD)

    note σ' heap_ok'
    moreover
    from frame ST' ST LT' suc_pc wf XX' h' hext
    have "conf_f P h' (X' # ST', LT') ins ?f"
      by(clarsimp simp add: fun_upd_apply conf_def split_beta)(auto intro: confs_hext confTs_hext)
    moreover
    from frames hext have "conf_fs P h' Φ M (size Ts) T frs" by (rule conf_fs_hext)
    moreover from tconf hext have "P,h'  t √t" by(rule tconf_hext_mono)
    ultimately
    show ?thesis using meth Φ' preh' by fastforce
  qed 
qed

lemma ALoad_correct:
  assumes wf:   "wf_prog wt P"
  assumes meth: "P  C sees M:TsT=(mxs,mxl0,ins,xt) in C"
  assumes ins:  "ins!pc = ALoad"
  assumes wt:   "P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M"
  assumes conf: "Φ  t: (None, h, (stk,loc,C,M,pc)#frs)"
  assumes no_x: "(tas, σ)  exec_instr (ins!pc) P t h stk loc C M pc frs"
  shows "Φ  t:σ "
proof - 
  from ins conf meth
  obtain ST LT where
    heap_ok: "hconf h" and
    tconf:   "P,h  t √t" and
    Φ_pc:    "Φ C M!pc = Some (ST,LT)" and
    stk: "P,h  stk [:≤] ST" and loc: "P,h  loc [:≤] LT" and
    pc: "pc < size ins" and 
    frame:   "conf_f P h (ST,LT) ins (stk,loc,C,M,pc)" and
    frames:  "conf_fs P h Φ M (size Ts) T frs" and
    preh:    "preallocated h"
    by (auto dest: sees_method_fun)

  from ins wt Φ_pc have lST: "length ST > 1" by(auto)

  show ?thesis
  proof(cases "hd (tl stk) = Null")
    case True
    with ins no_x heap_ok tconf Φ_pc stk loc frame frames meth wf_preallocatedD[OF wf, of h NullPointer] preh
    show ?thesis by(fastforce)
  next
    case False
    note stkNN = this
    have STNN: "hd (tl ST)  NT"
    proof
      assume "hd (tl ST) = NT"
      moreover 
      from frame have "P,h  stk [:≤] ST" by simp
      with lST have "P,h  hd (tl stk) :≤ hd (tl ST)"
        by (cases ST, auto, case_tac list, auto)
      ultimately 
      have "hd (tl stk) = Null" by simp
      with stkNN show False by contradiction
    qed

    with stkNN ins Φ_pc wt obtain ST'' X X' ST' LT' where 
      ST: "ST = Integer # X⌊⌉ # ST''" and
      pc': "pc+1 < size ins"  and
      Φ': "Φ C M ! (pc+1) = Some (X'#ST', LT')" and
      ST': "P  ST'' [≤] ST'" and LT': "P  LT [≤] LT'" and
      XX': "P  X  X'" and
      suc_pc:     "pc+1 < size ins"
      by(fastforce)

    from stk ST obtain ref idx stk' where 
      stk': "stk = idx#ref#stk'" and
      idx: "P,h  idx :≤ Integer" and
      ref:  "P,h  ref :≤ X⌊⌉" and
      ST'': "P,h  stk' [:≤] ST''"
      by auto

    from stkNN stk' have "ref  Null" by(simp)
    with ref obtain a Xel n
      where a: "ref = Addr a"
      and ha: "typeof_addr h a = Array_type Xel n"
      and Xel: "P  Xel  X"
      by(cases ref)(fastforce simp add: conf_def widen_Array)+

    from idx obtain idxI where idxI: "idx = Intg idxI"
      by(auto simp add: conf_def)
    show ?thesis
    proof(cases "0 <=s idxI  sint idxI < int n")
      case True
      hence si': "0 <=s idxI" "sint idxI < int n" by auto
      hence "nat (sint idxI) < n"
        by (simp add: word_sle_eq nat_less_iff)
      with ha have al: "P,h  a@ACell (nat (sint idxI)) : Xel" ..

      { fix v
        assume read: "heap_read h a (ACell (nat (sint idxI))) v"
        hence v: "P,h  v :≤ Xel" using al heap_ok by(rule heap_read_conf)

        let ?f = "(v # stk', loc, C, M, pc + 1)"
        
        from frame ST' ST LT' suc_pc wf XX' Xel idxI si' v ST''
        have "conf_f P h (X' # ST', LT') ins ?f"
          by(auto intro: widen_trans simp add: conf_def)
        hence "Φ  t:(None, h, ?f # frs) "
          using meth Φ' heap_ok Φ_pc frames tconf preh by fastforce }
      with ins meth si' stk' a ha no_x idxI idx 
      show ?thesis by(auto simp del: correct_state_def split: if_split_asm)
    next
      case False
      with stk' idxI ins no_x heap_ok tconf meth a ha Xel Φ_pc frame frames
        wf_preallocatedD[OF wf, of h ArrayIndexOutOfBounds] preh
      show ?thesis by(fastforce split: if_split_asm)
    qed
  qed
qed


lemma AStore_correct:
  assumes wf:   "wf_prog wt P"
  assumes meth: "P  C sees M:TsT=(mxs,mxl0,ins,xt) in C"
  assumes ins:  "ins!pc = AStore"
  assumes wt:   "P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M"
  assumes conf: "Φ  t: (None, h, (stk,loc,C,M,pc)#frs)"
  assumes no_x: "(tas, σ)  exec_instr (ins!pc) P t h stk loc C M pc frs"
  shows "Φ  t: σ "
proof - 
  from ins conf meth
  obtain ST LT where
    heap_ok: "hconf h" and
    tconf: "P,h  t √t" and
    Φ_pc:    "Φ C M!pc = Some (ST,LT)" and
    stk: "P,h  stk [:≤] ST" and loc: "P,h  loc [:≤] LT" and
    pc: "pc < size ins" and 
    frame:   "conf_f P h (ST,LT) ins (stk,loc,C,M,pc)" and
    frames:  "conf_fs P h Φ M (size Ts) T frs" and
    preh:    "preallocated h"
    by (auto dest: sees_method_fun)

  from ins wt Φ_pc have lST: "length ST > 2" by(auto)
  
  show ?thesis
  proof(cases "hd (tl (tl stk)) = Null")
    case True
    with ins no_x heap_ok tconf Φ_pc stk loc frame frames meth wf_preallocatedD[OF wf, of h NullPointer] preh
    show ?thesis by(fastforce)
  next
    case False
    note stkNN = this
    have STNN: "hd (tl (tl ST))  NT"       
    proof
      assume "hd (tl (tl ST)) = NT"
      moreover 
      from frame have "P,h  stk [:≤] ST" by simp
      with lST have "P,h  hd (tl (tl stk)) :≤ hd (tl (tl ST))"
        by (cases ST, auto, case_tac list, auto, case_tac lista, auto)
      ultimately 
      have "hd (tl (tl stk)) = Null" by simp
      with stkNN show False by contradiction
    qed

    with ins stkNN Φ_pc wt obtain ST'' Y X ST' LT' where 
      ST: "ST = Y # Integer # X⌊⌉ # ST''" and
      pc': "pc+1 < size ins"  and
      Φ': "Φ C M ! (pc+1) = Some (ST', LT')" and
      ST': "P  ST'' [≤] ST'" and LT': "P  LT [≤] LT'" and
      suc_pc:     "pc+1 < size ins"
      by(fastforce)

    from stk ST obtain ref e idx stk' where 
      stk': "stk = e#idx#ref#stk'" and
      idx: "P,h  idx :≤ Integer" and
      ref:  "P,h  ref :≤ X⌊⌉" and
      e: "P,h  e :≤ Y" and
      ST'': "P,h  stk' [:≤] ST''"
      by auto

    from stkNN stk' have "ref  Null" by(simp)
    with ref obtain a Xel n
      where a: "ref = Addr a"
      and ha: "typeof_addr h a = Array_type Xel n"
      and Xel: "P  Xel  X"
      by(cases ref)(fastforce simp add: conf_def widen_Array)+

    from idx obtain idxI where idxI: "idx = Intg idxI"
      by(auto simp add: conf_def)
    
    show ?thesis
    proof(cases "0 <=s idxI  sint idxI < int n")
      case True
      hence si': "0 <=s idxI" "sint idxI < int n" by simp_all

      from e obtain Te where Te: "typeofh e = Te" "P  Te  Y"
        by(auto simp add: conf_def)

      show ?thesis
      proof(cases "P  Te  Xel")
        case True
        with Te have eXel: "P,h  e :≤ Xel"
          by(auto simp add: conf_def intro: widen_trans)

        { fix h'
          assume "write": "heap_write h a (ACell (nat (sint idxI))) e h'"
          hence hext: "h  h'" by(rule hext_heap_write)
          with preh have preh': "preallocated h'" by(rule preallocated_hext)

          let ?f = "(stk', loc, C, M, pc + 1)"

          from si' have "nat (sint idxI) < n"
            by (simp add: word_sle_eq nat_less_iff)
          with ha have "P,h  a@ACell (nat (sint idxI)) : Xel" ..
          with "write" heap_ok have heap_ok': "hconf h'" using eXel
            by(rule hconf_heap_write_mono)
          moreover
          from ST stk stk' ST' have "P,h  stk' [:≤] ST'" by auto
          with hext have stk'': "P,h'  stk' [:≤] ST'"
            by- (rule confs_hext)
          moreover
          from loc LT' have "P,h  loc [:≤] LT'" ..
          with hext have "P,h'  loc [:≤] LT'" by - (rule confTs_hext)
          moreover
          with frame ST' ST LT' suc_pc wf Xel idxI si' stk''
          have "conf_f P h' (ST', LT') ins ?f"
            by(clarsimp)
          with frames hext have "conf_fs P h' Φ M (size Ts) T frs" by- (rule conf_fs_hext)
          moreover from tconf hext have "P,h'  t √t" by(rule tconf_hext_mono)
          ultimately have "Φ  t:(None, h', ?f # frs) " using meth Φ' Φ_pc suc_pc preh'
            by(fastforce) }
        with True si' ins meth stk' a ha no_x idxI idx Te
        show ?thesis
          by(auto split: if_split_asm simp del: correct_state_def intro: widen_trans)
      next
        case False
        with stk' idxI ins no_x heap_ok tconf meth a ha Xel Te Φ_pc frame frames si' preh
          wf_preallocatedD[OF wf, of h ArrayStore]
        show ?thesis by(fastforce split: if_split_asm)
      qed
    next
      case False
      with stk' idxI ins no_x heap_ok tconf meth a ha Xel Φ_pc frame frames preh
        wf_preallocatedD[OF wf, of h ArrayIndexOutOfBounds]
      show ?thesis by(fastforce split: if_split_asm)
    qed
  qed
qed

lemma ALength_correct:
  assumes wf:   "wf_prog wt P"
  assumes meth: "P  C sees M:TsT=(mxs,mxl0,ins,xt) in C"
  assumes ins:  "ins!pc = ALength"
  assumes wt:   "P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M"
  assumes conf: "Φ  t: (None, h, (stk,loc,C,M,pc)#frs)"
  assumes no_x: "(tas, σ)  exec_instr (ins!pc) P t h stk loc C M pc frs"
  shows "Φ  t: σ "
proof - 
  from ins conf meth
  obtain ST LT where
    heap_ok: "hconf h" and
    tconf:   "P,h  t √t" and
    Φ_pc:    "Φ C M!pc = Some (ST,LT)" and
    stk: "P,h  stk [:≤] ST" and loc: "P,h  loc [:≤] LT" and
    pc: "pc < size ins" and 
    frame:   "conf_f P h (ST,LT) ins (stk,loc,C,M,pc)" and
    frames:  "conf_fs P h Φ M (size Ts) T frs" and
    preh:    "preallocated h"
    by (auto dest: sees_method_fun)

  from ins wt Φ_pc have lST: "length ST > 0" by(auto)
  
  show ?thesis
  proof(cases "hd stk = Null")
    case True
    with ins no_x heap_ok tconf Φ_pc stk loc frame frames meth wf_preallocatedD[OF wf, of h NullPointer] preh
    show ?thesis by(fastforce)
  next
    case False
    note stkNN = this
    have STNN: "hd ST  NT"
    proof
      assume "hd ST = NT"
      moreover 
      from frame have "P,h  stk [:≤] ST" by simp
      with lST have "P,h  hd stk :≤ hd ST"
        by (cases ST, auto)
      ultimately 
      have "hd stk = Null" by simp
      with stkNN show False by contradiction
    qed

    with stkNN ins Φ_pc wt obtain ST'' X ST' LT' where 
      ST: "ST = (X⌊⌉) # ST''" and
      pc': "pc+1 < size ins"  and
      Φ': "Φ C M ! (pc+1) = Some (ST', LT')" and
      ST': "P  (Integer # ST'') [≤] ST'" and LT': "P  LT [≤] LT'" and
      suc_pc:     "pc+1 < size ins"
      by(fastforce)

    from stk ST obtain ref stk' where 
      stk': "stk = ref#stk'" and
      ref:  "P,h  ref :≤ X⌊⌉" and
      ST'': "P,h  stk' [:≤] ST''"
      by auto

    from stkNN stk' have "ref  Null" by(simp)
    with ref obtain a Xel n
      where a: "ref = Addr a"
      and ha: "typeof_addr h a = Array_type Xel n"
      and Xel: "P  Xel  X"
      by(cases ref)(fastforce simp add: conf_def widen_Array)+

    from ins meth stk' a ha no_x have σ':
      "σ = (None, h, (Intg (word_of_int (int n)) # stk', loc, C, M, pc + 1) # frs)"
      (is "σ = (None, h, ?f # frs)")
      by(auto)
    moreover
    from ST stk stk' ST' have "P,h  Intg si # stk' [:≤] ST'" by(auto)
    with frame ST' ST LT' suc_pc wf
    have "conf_f P h (ST', LT') ins ?f"
      by(fastforce intro: widen_trans)
    ultimately show ?thesis using meth Φ' heap_ok Φ_pc frames tconf preh by fastforce
  qed
qed


lemma MEnter_correct:
  assumes wf:   "wf_prog wt P"
  assumes meth: "P  C sees M:TsT=(mxs,mxl0,ins,xt) in C"
  assumes ins:  "ins!pc = MEnter"
  assumes wt:   "P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M"
  assumes conf: "Φ  t: (None, h, (stk,loc,C,M,pc)#frs)"
  assumes no_x: "(tas, σ)  exec_instr (ins!pc) P t h stk loc C M pc frs"
  shows "Φ  t: σ "
proof - 
  from ins conf meth
  obtain ST LT where
    heap_ok: "hconf h" and
    tconf:   "P,h  t √t" and
    Φ_pc:    "Φ C M!pc = Some (ST,LT)" and
    stk: "P,h  stk [:≤] ST" and loc: "P,h  loc [:≤] LT" and
    pc: "pc < size ins" and 
    frame:   "conf_f P h (ST,LT) ins (stk,loc,C,M,pc)" and
    frames:  "conf_fs P h Φ M (size Ts) T frs" and
    preh:    "preallocated h"
    by (auto dest: sees_method_fun)

  from ins wt Φ_pc have lST: "length ST > 0" by(auto)

  show ?thesis
  proof(cases "hd stk = Null")
    case True
    with ins no_x heap_ok tconf Φ_pc stk loc frame frames meth wf_preallocatedD[OF wf, of h NullPointer] preh
    show ?thesis by(fastforce)
  next
    case False
    note stkNN = this
    have STNN: "hd ST  NT"
    proof
      assume "hd ST = NT"
      moreover 
      from frame have "P,h  stk [:≤] ST" by simp
      with lST have "P,h  hd stk :≤ hd ST"
        by (cases ST, auto)
      ultimately 
      have "hd stk = Null" by simp
      with stkNN show False by contradiction
    qed

    with stkNN ins Φ_pc wt obtain ST'' X ST' LT' where 
      ST: "ST = X # ST''" and
      refT: "is_refT X" and
      pc': "pc+1 < size ins"  and
      Φ': "Φ C M ! (pc+1) = Some (ST', LT')" and
      ST': "P  ST'' [≤] ST'" and LT': "P  LT [≤] LT'" and
      suc_pc:     "pc+1 < size ins"
      by(fastforce)

    from stk ST obtain ref stk' where 
      stk': "stk = ref#stk'" and
      ref:  "P,h  ref :≤ X"
      by auto

    from stkNN stk' have "ref  Null" by(simp)
    moreover
    from loc LT' have "P,h  loc [:≤] LT'" ..
    moreover
    from ST stk stk' ST'
    have "P,h  stk' [:≤] ST'" by(auto)
    ultimately show ?thesis using meth Φ' heap_ok Φ_pc suc_pc frames loc LT' no_x ins stk' ST' tconf preh
      by(fastforce)
  qed
qed

lemma MExit_correct:
  assumes wf:   "wf_prog wt P"
  assumes meth: "P  C sees M:TsT=(mxs,mxl0,ins,xt) in C"
  assumes ins:  "ins!pc = MExit"
  assumes wt:   "P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M"
  assumes conf: "Φ  t: (None, h, (stk,loc,C,M,pc)#frs)"
  assumes no_x: "(tas, σ)  exec_instr (ins!pc) P t h stk loc C M pc frs"
  shows "Φ  t: σ "
proof - 
  from ins conf meth
  obtain ST LT where
    heap_ok: "hconf h" and
    tconf:   "P,h  t √t" and
    Φ_pc:    "Φ C M!pc = Some (ST,LT)" and
    stk: "P,h  stk [:≤] ST" and loc: "P,h  loc [:≤] LT" and
    pc: "pc < size ins" and 
    frame:   "conf_f P h (ST,LT) ins (stk,loc,C,M,pc)" and
    frames:  "conf_fs P h Φ M (size Ts) T frs" and
    preh:    "preallocated h"
    by (auto dest: sees_method_fun)

  from ins wt Φ_pc have lST: "length ST > 0" by(auto)

  show ?thesis
  proof(cases "hd stk = Null")
    case True
    with ins no_x heap_ok tconf Φ_pc stk loc frame frames meth wf_preallocatedD[OF wf, of h NullPointer] preh
    show ?thesis by(fastforce)
  next
    case False
    note stkNN = this
    have STNN: "hd ST  NT"
    proof
      assume "hd ST = NT"
      moreover 
      from frame have "P,h  stk [:≤] ST" by simp
      with lST have "P,h  hd stk :≤ hd ST"
        by (cases ST, auto)
      ultimately 
      have "hd stk = Null" by simp
      with stkNN show False by contradiction
    qed

    with stkNN ins Φ_pc wt obtain ST'' X ST' LT' where 
      ST: "ST = X # ST''" and
      refT: "is_refT X" and
      pc': "pc+1 < size ins"  and
      Φ': "Φ C M ! (pc+1) = Some (ST', LT')" and
      ST': "P  ST'' [≤] ST'" and LT': "P  LT [≤] LT'" and
      suc_pc:     "pc+1 < size ins"
      by(fastforce)

    from stk ST obtain ref stk' where 
      stk': "stk = ref#stk'" and
      ref:  "P,h  ref :≤ X"
      by auto

    from stkNN stk' have "ref  Null" by(simp)
    moreover
    from loc LT' have "P,h  loc [:≤] LT'" ..
    moreover
    from ST stk stk' ST'
    have "P,h  stk' [:≤] ST'" by(auto)
    ultimately 
    show ?thesis using meth Φ' heap_ok Φ_pc suc_pc frames loc LT' no_x ins stk' ST' tconf frame preh
      wf_preallocatedD[OF wf, of h IllegalMonitorState]
      by(fastforce)
  qed
qed

text ‹
  The next theorem collects the results of the sections above,
  i.e.~exception handling and the execution step for each 
  instruction. It states type safety for single step execution:
  in welltyped programs, a conforming state is transformed
  into another conforming state when one instruction is executed.
›
theorem instr_correct:
" wf_jvm_progΦ P;
  P  C sees M:TsT=(mxs,mxl0,ins,xt) in C;
  (tas, σ')  exec P t (None, h, (stk,loc,C,M,pc)#frs); 
  Φ  t: (None, h, (stk,loc,C,M,pc)#frs)  
 Φ  t: σ'"
apply (subgoal_tac "P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M")
 prefer 2
 apply (erule wt_jvm_prog_impl_wt_instr, assumption)
 apply clarsimp
 apply (drule (1) sees_method_fun)
 apply simp
apply(unfold exec.simps Let_def set_map)
apply (frule wt_jvm_progD, erule exE)
apply (cases "ins ! pc")
apply (rule Load_correct, assumption+, fastforce)
apply (rule Store_correct, assumption+, fastforce)
apply (rule Push_correct, assumption+, fastforce)
apply (rule New_correct, assumption+, fastforce)
apply (rule NewArray_correct, assumption+, fastforce)
apply (rule ALoad_correct, assumption+, fastforce)
apply (rule AStore_correct, assumption+, fastforce)
apply (rule ALength_correct, assumption+, fastforce)
apply (rule Getfield_correct, assumption+, fastforce)
apply (rule Putfield_correct, assumption+, fastforce)
apply (rule CAS_correct, assumption+, fastforce)
apply (rule Checkcast_correct, assumption+, fastforce)
apply (rule Instanceof_correct, assumption+, fastforce)
apply (rule Invoke_correct, assumption+, fastforce)
apply (rule Return_correct, assumption+, fastforce simp add: split_beta)
apply (rule Pop_correct, assumption+, fastforce)
apply (rule Dup_correct, assumption+, fastforce)
apply (rule Swap_correct, assumption+, fastforce)
apply (rule BinOp_correct, assumption+, fastforce)
apply (rule Goto_correct, assumption+, fastforce)
apply (rule IfFalse_correct, assumption+, fastforce)
apply (rule Throw_correct, assumption+, fastforce)
apply (rule MEnter_correct, assumption+, fastforce)
apply (rule MExit_correct, assumption+, fastforce)
done

declare defs1 [simp del]

end

subsection ‹Main›

lemma (in JVM_conf_read) BV_correct_1 [rule_format]:
"σ.  wf_jvm_progΦ P; Φ  t: σ  P,t  σ -tas-jvm→ σ'  Φ  t: σ'"
apply (simp only: split_tupled_all exec_1_iff)
apply (rename_tac xp h frs)
apply (case_tac xp)
 apply (case_tac frs)
  apply simp
 apply (simp only: split_tupled_all)
 apply hypsubst
 apply (frule correct_state_impl_Some_method)
 apply clarify
 apply (rule instr_correct)
 apply assumption+
apply clarify
apply(case_tac frs)
 apply simp
apply(clarsimp simp only: exec.simps set_simps)
apply(erule (1) exception_step_conform)
done

theorem (in JVM_progress) progress:
  assumes wt: "wf_jvm_progΦ P"
  and cs: "Φ  t: (xcp, h, f # frs)"
  shows "ta σ'. P,t  (xcp, h, f # frs) -ta-jvm→ σ'"
proof -
  obtain stk loc C M pc where f: "f = (stk, loc, C, M, pc)" by(cases f)
  with cs obtain Ts T mxs mxl0 "is" xt ST LT
    where hconf: "hconf h"
    and sees: "P  C sees M: TsT = (mxs, mxl0, is, xt) in C"
    and Φ_pc: "Φ C M ! pc = (ST, LT)"
    and ST: "P,h  stk [:≤] ST"
    and LT: "P,h  loc [:≤] LT"
    and pc: "pc < length is"
    by(auto simp add: defs1)
  show ?thesis
  proof(cases xcp)
    case Some thus ?thesis
      unfolding f exec_1_iff by auto
  next
    case [simp]: None
    note [simp del] = split_paired_Ex
    note [simp] = defs1 list_all2_Cons2


    from wt obtain wf_md where wf: "wf_prog wf_md P" by(auto dest: wt_jvm_progD)
    from wt sees pc have wt: "P,T,mxs,size is,xt  is!pc,pc :: Φ C M"
      by(rule wt_jvm_prog_impl_wt_instr)


    have "ta σ'. (ta, σ')  exec_instr (is ! pc) P t h stk loc C M pc frs"
    proof(cases "is ! pc")
      case [simp]: ALoad
      with wt Φ_pc have lST: "length ST > 1" by(auto)
      show ?thesis
      proof(cases "hd (tl stk) = Null")
        case True thus ?thesis by simp
      next
        case False
        have STNN: "hd (tl ST)  NT"
        proof
          assume "hd (tl ST) = NT"
          moreover 
          from ST lST have "P,h  hd (tl stk) :≤ hd (tl ST)"
            by (cases ST)(auto, case_tac list, auto)
          ultimately have "hd (tl stk) = Null" by simp
          with False show False by contradiction
        qed
        
        with False Φ_pc wt obtain ST'' X where "ST = Integer # X⌊⌉ # ST''" by auto
        with ST obtain ref idx stk' where stk': "stk = idx#ref#stk'" and idx: "P,h  idx :≤ Integer" 
          and ref:  "P,h  ref :≤ X⌊⌉" by(auto)

        from False stk' have "ref  Null" by(simp)
        with ref obtain a Xel n where a: "ref = Addr a"
          and ha: "typeof_addr h a = Array_type Xel n"
          and Xel: "P  Xel  X"
          by(cases ref)(fastforce simp add: conf_def widen_Array)+
        
        from idx obtain idxI where idxI: "idx = Intg idxI"
          by(auto simp add: conf_def)
        show ?thesis
        proof(cases "0 <=s idxI  sint idxI < int n")
          case True
          hence si': "0 <=s idxI" "sint idxI < int n" by auto
          hence "nat (sint idxI) < n"
            by (simp add: word_sle_eq nat_less_iff)
          with ha have al: "P,h  a@ACell (nat (sint idxI)) : Xel" ..
          from heap_read_total[OF hconf this] True False ha stk' idxI a
          show ?thesis by auto
        next
          case False with ha stk' idxI a show ?thesis by auto
        qed
      qed
    next
      case [simp]: AStore
      from wt Φ_pc have lST: "length ST > 2" by(auto)
      
      show ?thesis
      proof(cases "hd (tl (tl stk)) = Null")
        case True thus ?thesis by(fastforce)
      next
        case False
        note stkNN = this
        have STNN: "hd (tl (tl ST))  NT"       
        proof
          assume "hd (tl (tl ST)) = NT"
          moreover 
          from ST lST have "P,h  hd (tl (tl stk)) :≤ hd (tl (tl ST))"
            by (cases ST, auto, case_tac list, auto, case_tac lista, auto)
          ultimately have "hd (tl (tl stk)) = Null" by simp
          with stkNN show False by contradiction
        qed

        with stkNN Φ_pc wt obtain ST'' Y X
          where "ST = Y # Integer # X⌊⌉ # ST''" by(fastforce)

        with ST obtain ref e idx stk' where stk': "stk = e#idx#ref#stk'" 
          and idx: "P,h  idx :≤ Integer" and ref:  "P,h  ref :≤ X⌊⌉" 
          and e: "P,h  e :≤ Y" by auto

        from stkNN stk' have "ref  Null" by(simp)
        with ref obtain a Xel n where a: "ref = Addr a"
          and ha: "typeof_addr h a = Array_type Xel n"
          and Xel: "P  Xel  X"
          by(cases ref)(fastforce simp add: conf_def widen_Array)+

        from idx obtain idxI where idxI: "idx = Intg idxI"
          by(auto simp add: conf_def)
        
        show ?thesis
        proof(cases "0 <=s idxI  sint idxI < int n")
          case True
          hence si': "0 <=s idxI" "sint idxI < int n" by simp_all
          hence "nat (sint idxI) < n"
            by (simp add: word_sle_eq nat_less_iff)
          with ha have adal: "P,h  a@ACell (nat (sint idxI)) : Xel" ..
          
          show ?thesis
          proof(cases "P  the (typeofh e)  Xel")
            case False
            with ha stk' idxI a show ?thesis by auto
          next
            case True
            hence "P,h  e :≤ Xel" using e by(auto simp add: conf_def)
            from heap_write_total[OF hconf adal this] ha stk' idxI a show ?thesis by auto
          qed
        next
          case False with ha stk' idxI a show ?thesis by auto
        qed
      qed
    next
      case [simp]: (Getfield F D)

      from Φ_pc wt obtain oT ST'' vT fm where oT: "P  oT  Class D" 
        and "ST = oT # ST''" and F: "P  D sees F:vT (fm) in D" 
        by fastforce

      with ST obtain ref stk' where stk': "stk = ref#stk'" 
        and ref:  "P,h  ref :≤ oT" by auto

      show ?thesis
      proof(cases "ref = Null")
        case True thus ?thesis using stk' by auto
      next
        case False
        from ref oT have "P,h  ref :≤ Class D" ..
        with False obtain a U' D' where 
          a: "ref = Addr a" and h: "typeof_addr h a = Some U'"
          and U': "D' = class_type_of U'" and D': "P  D' * D"
          by (blast dest: non_npD2)
    
        from D' F have has_field: "P  D' has F:vT (fm) in D"
          by (blast intro: has_field_mono has_visible_field)
        with h have "P,h  a@CField D F : vT" unfolding U' ..
        from heap_read_total[OF hconf this]
        show ?thesis using stk' a by auto
      qed
    next
      case [simp]: (Putfield F D)

      from Φ_pc wt obtain vT vT' oT ST'' fm where "ST = vT # oT # ST''" 
        and field: "P  D sees F:vT' (fm) in D"
        and oT: "P  oT  Class D"
        and vT': "P  vT  vT'" by fastforce
      with ST obtain v ref stk' where stk': "stk = v#ref#stk'" 
        and ref:  "P,h  ref :≤ oT" 
        and v: "P,h  v :≤ vT" by auto

      show ?thesis
      proof(cases "ref = Null")
        case True with stk' show ?thesis by auto
      next
        case False
        from ref oT have "P,h  ref :≤ Class D" ..
        with False obtain a U' D' where 
          a: "ref = Addr a" and h: "typeof_addr h a = Some U'" and
          U': "D' = class_type_of U'" and D': "P  D' * D"
          by (blast dest: non_npD2)

        from field D' have has_field: "P  D' has F:vT' (fm) in D"
          by (blast intro: has_field_mono has_visible_field)
        with h have al: "P,h  a@CField D F : vT'" unfolding U' ..
        from v vT' have "P,h  v :≤ vT'" by auto
        from heap_write_total[OF hconf al this] v a stk' h show ?thesis by auto
      qed
    next
      case [simp]: (CAS F D)
      from Φ_pc wt obtain T' T1 T2 T3 ST'' fm where "ST = T3 # T2 # T1 # ST''" 
        and field: "P  D sees F:T' (fm) in D"
        and oT: "P  T1  Class D"
        and vT': "P  T2  T'" "P  T3  T'" by fastforce
      with ST obtain v v' v'' stk' where stk': "stk = v''#v'#v#stk'" 
        and v:  "P,h  v :≤ T1" 
        and v': "P,h  v' :≤ T2"
        and v'': "P,h  v'' :≤ T3" by auto
      show ?thesis
      proof(cases "v= Null")
        case True with stk' show ?thesis by auto
      next
        case False
        from v oT have "P,h  v :≤ Class D" ..
        with False obtain a U' D' where 
          a: "v = Addr a" and h: "typeof_addr h a = Some U'" and
          U': "D' = class_type_of U'" and D': "P  D' * D"
          by (blast dest: non_npD2)

        from field D' have has_field: "P  D' has F:T' (fm) in D"
          by (blast intro: has_field_mono has_visible_field)
        with h have al: "P,h  a@CField D F : T'" unfolding U' ..
        from v' vT' have "P,h  v' :≤ T'" by auto
        from heap_read_total[OF hconf al] obtain v''' where v''': "heap_read h a (CField D F) v'''" by blast
        show ?thesis
        proof(cases "v''' = v'")
          case True
          from v'' vT' have "P,h  v'' :≤ T'" by auto
          from heap_write_total[OF hconf al this] v a stk' h v''' True show ?thesis by auto
        next
          case False
          from v''' v a stk' h False show ?thesis by auto
        qed
      qed
    next
      case [simp]: (Invoke M' n)

      from wt Φ_pc have n: "n < size ST" by simp
  
      show ?thesis
      proof(cases "stk!n = Null")
        case True thus ?thesis by simp
      next
        case False
        note Null = this
        have NT: "ST!n  NT"
        proof
          assume "ST!n = NT"
          moreover from ST n have "P,h  stk!n :≤ ST!n" by (simp add: list_all2_conv_all_nth)
          ultimately have "stk!n = Null" by simp
          with Null show False by contradiction
        qed

        from NT wt Φ_pc obtain D D' Ts T m
          where D: "class_type_of' (ST!n) = Some D"
          and m_D: "P  D sees M': TsT = m in D'"
          and Ts:  "P  rev (take n ST) [≤] Ts"
          by auto

        from n ST D have "P,h  stk!n :≤ ST!n"
          by (auto simp add: list_all2_conv_all_nth)

        from P,h  stk!n :≤ ST!n Null D
        obtain a T' where
          Addr:   "stk!n = Addr a" and
          obj:    "typeof_addr h a = Some T'" and
          T'subSTn: "P  ty_of_htype T'  ST ! n"
          by(cases "stk ! n")(auto simp add: conf_def widen_Class)

        from D T'subSTn obtain C' where
          C': "class_type_of' (ty_of_htype T') = C'" and C'subD: "P  C' * D"
          by(rule widen_is_class_type_of) simp

        from Call_lemma[OF m_D C'subD wf]
        obtain D' Ts' T' m' 
          where Call': "P  C' sees M': Ts'T' = m' in D'" "P  Ts [≤] Ts'"
            "P  T'  T" "P  C' * D'" "is_type P T'" "Tset Ts'. is_type P T"
          by blast
        
        show ?thesis
        proof(cases m')
          case Some with Call' C' obj Addr C' C'subD show ?thesis by(auto)
        next
          case [simp]: None
          from ST have "P,h  take n stk [:≤] take n ST" by(rule list_all2_takeI)
          then obtain Us where "map typeofh (take n stk) = map Some Us" "P  Us [≤] take n ST"
            by(auto simp add: confs_conv_map)
          hence Us: "map typeofh (rev (take n stk)) = map Some (rev Us)" "P  rev Us [≤] rev (take n ST)"
            by- (simp only: rev_map[symmetric], simp)
          with Ts P  Ts [≤] Ts' have "P  rev Us [≤] Ts'" by(blast intro: widens_trans)
          with obj Us Call' C' have "P,h  aM'(rev (take n stk)) : T'"
            by(auto intro!: external_WT'.intros)
          from external_call_progress[OF wf this hconf, of t] obj Addr Call' C'
          show ?thesis by(auto dest!: red_external_imp_red_external_aggr)
        qed
      qed
    qed(auto 4 4 simp add: split_beta split: if_split_asm)
    thus ?thesis using sees None
      unfolding f exec_1_iff by(simp del: split_paired_Ex)
  qed
qed

lemma (in JVM_heap_conf) BV_correct_initial:
  shows " wf_jvm_progΦ P; start_heap_ok; P  C sees M:TsT = m in D; P,start_heap  vs [:≤] Ts 
   Φ  start_tid:JVM_start_state' P C M vs "
  apply (cases m)
  apply (unfold JVM_start_state'_def)
  apply (unfold correct_state_def)
  apply (clarsimp)
  apply (frule wt_jvm_progD)
  apply (erule exE)
  apply (frule wf_prog_wf_syscls)
  apply (rule conjI)
   apply(erule (1) tconf_start_heap_start_tid)
  apply(rule conjI)
   apply (simp add: wf_jvm_prog_phi_def hconf_start_heap) 
  apply(frule sees_method_idemp)
  apply (frule wt_jvm_prog_impl_wt_start, assumption+)
  apply (unfold conf_f_def wt_start_def)
  apply(auto simp add: sup_state_opt_any_Some)
   apply(erule preallocated_start_heap)
  apply(rule exI conjI|assumption)+
  apply(auto simp add: list_all2_append1)
  apply(auto dest: list_all2_lengthD intro!: exI)
  done

end

Theory BVNoTypeError

(*  Title:      JinjaThreads/BV/BVNoTypeError.thy
    Author:     Gerwin Klein, Andreas Lochbihler
*)

section ‹Welltyped Programs produce no Type Errors›

theory BVNoTypeError
imports
  "../JVM/JVMDefensive"
  BVSpecTypeSafe
begin

lemma wt_jvm_prog_states:
  " wf_jvm_progΦ P; P  C sees M: TsT = (mxs, mxl, ins, et) in C; 
     Φ C M ! pc = τ; pc < size ins 
   OK τ  states P mxs (1+size Ts+mxl)"
(*<*)
  apply (unfold wf_jvm_prog_phi_def)
  apply (drule (1) sees_wf_mdecl)
  apply (simp add: wf_mdecl_def wt_method_def check_types_def)
  apply (blast intro: nth_in)
  done
(*>*)

context JVM_heap_conf_base' begin

declare is_IntgI [simp, intro]
declare is_BoolI [simp, intro]
declare is_RefI [simp]

text ‹
  The main theorem: welltyped programs do not produce type errors if they
  are started in a conformant state.
›
theorem no_type_error:
  assumes welltyped: "wf_jvm_progΦ P" and conforms: "Φ  t:σ "
  shows "exec_d P t σ  TypeError"
(*<*)
proof -
  from welltyped obtain mb where wf: "wf_prog mb P" by (fast dest: wt_jvm_progD)
  
  obtain xcp h frs where s [simp]: "σ = (xcp, h, frs)" by (cases σ)

  have "check P σ"
  proof(cases frs)
    case Nil with conforms show ?thesis by (unfold correct_state_def check_def) auto
  next
    case (Cons f frs')
    then obtain stk reg C M pc where frs [simp]: "frs = (stk,reg,C,M,pc)#frs'"
      and f: "f = (stk,reg,C,M,pc)" by(cases f) fastforce

    from conforms obtain  ST LT Ts T mxs mxl ins xt where
      hconf:  "hconf h" and
      tconf:  "P,h  t √t" and
      meth:   "P  C sees M:TsT = (mxs, mxl, ins, xt) in C" and
      Φ:      "Φ C M ! pc = Some (ST,LT)" and
      frame:  "conf_f P h (ST,LT) ins (stk,reg,C,M,pc)" and
      frames: "conf_fs P h Φ M (size Ts) T frs'" and
      confxcp: "conf_xcp P h xcp (ins ! pc)"
      by (fastforce simp add: correct_state_def dest: sees_method_fun)

    from frame obtain
      stk: "P,h  stk [:≤] ST" and
      reg: "P,h  reg [:≤] LT" and
      pc:  "pc < size ins" 
      by (simp add: conf_f_def)

    from welltyped meth Φ pc
    have "OK (Some (ST, LT))  states P mxs (1+size Ts+mxl)"
      by (rule wt_jvm_prog_states)
    hence "size ST  mxs" by (auto simp add: JVM_states_unfold listE_length)
    with stk have mxs: "size stk  mxs" 
      by (auto dest: list_all2_lengthD)

    from welltyped meth pc
    have "P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M"
      by (rule wt_jvm_prog_impl_wt_instr)
    hence app0: "app (ins!pc) P mxs T pc (size ins) xt (Φ C M!pc) "
      by (simp add: wt_instr_def)
    with Φ have eff: 
      "(pc',s')set (eff (ins ! pc) P pc xt (Φ C M ! pc)). pc' < size ins"
      by (unfold app_def) simp
    
    from app0 Φ have app:
      "xcpt_app (ins!pc) P pc mxs xt (ST,LT)  appi (ins!pc, P, pc, mxs, T, (ST,LT))"
      by (clarsimp simp add: app_def)

    show ?thesis
    proof(cases xcp)
      case None
      note xcp[simp] = this

      from app eff stk reg 
      have "check_instr (ins!pc) P h stk reg C M pc frs'"
      proof (cases "ins!pc")
        case ALoad
        with app stk reg Φ obtain T ST' where
          ST: "ST = Integer # T # ST'" and
          TNT: "T  NT  (T'. T = T'⌊⌉)"
          by auto
        from stk ST obtain i stk' ref where
          stk': "stk = Intg i # ref # stk'" and
          ref: "P,h  ref :≤ T"
          by(auto simp add: conf_def list_all2_Cons2)
        
        from ref TNT have is_Ref: "is_Ref ref"
          by(cases ref)(auto simp add: is_Ref_def conf_def)
        moreover
        { assume refN: "ref  Null"
          with ref have "T  NT" by auto
          with TNT obtain T' where T': "T = T'⌊⌉" by auto
          with ref refN is_Ref wf
          have "T n. typeof_addr h (the_Addr ref) = Array_type T n"
            by(cases ref)(auto simp add:conf_def widen_Array) }
        ultimately show ?thesis using ALoad stk'
          by(auto)
      next
        case AStore
        with app stk reg Φ obtain T U ST' where
          ST: "ST = T # Integer # U # ST'" and
          TNT: "U  NT  (T'. U = T'⌊⌉)"
          by auto
        from stk ST obtain e i stk' ref where
          stk': "stk = e # Intg i # ref # stk'" and
          ref: "P,h  ref :≤ U" and
          e: "P,h  e :≤ T"
          by(fastforce simp add: conf_def list_all2_Cons2)
        
        from ref TNT have is_Ref: "is_Ref ref"
          by(cases ref)(auto simp add: is_Ref_def conf_def)
        moreover
        { assume refN: "ref  Null"
          with ref have "U  NT" by auto
          with TNT obtain T' where T': "U = T'⌊⌉" by auto
          with ref refN is_Ref wf
          have "T n. typeof_addr h (the_Addr ref) = Array_type T n"
            by(cases ref)(auto simp add:conf_def widen_Array) }
        ultimately show ?thesis using AStore stk' e by(auto simp add: conf_def)
      next
        case ALength
        with app stk reg Φ obtain T ST' where
          ST: "ST = T # ST'" and
          TNT: "T  NT  (T'. T = T'⌊⌉)"
          by auto
        from stk ST obtain stk' ref where
          stk': "stk = ref # stk'" and
          ref: "P,h  ref :≤ T"
          by(auto simp add: conf_def list_all2_Cons2)
      
        from ref TNT have is_Ref: "is_Ref ref"
          by(cases ref)(auto simp add: is_Ref_def conf_def)
        moreover
        { assume refN: "ref  Null"
          with ref have "T  NT" by auto
          with TNT obtain T' where T': "T = T'⌊⌉" by auto
          with ref refN is_Ref wf
          have "T n. typeof_addr h (the_Addr ref) = Array_type T n"
            by(cases ref)(auto simp add:conf_def widen_Array) }
        ultimately show ?thesis using ALength stk'
          by(auto)
      next
        case (Getfield F C) 
        with app stk reg Φ obtain v vT stk' fm where
          field: "P  C sees F:vT (fm) in C" and
          stk:   "stk = v # stk'" and
          conf:  "P,h  v :≤ Class C"
          by(fastforce simp add: list_all2_Cons2)
        from conf have is_Ref: "is_Ref v" by(cases v)(auto simp add: is_Ref_def conf_def)
        moreover {
          assume "v  Null" 
          with conf field is_Ref wf 
          have "U. typeof_addr h (the_Addr v) = Some U  P  class_type_of U * C"
            by (auto dest!: non_npD2)
        }
        ultimately show ?thesis using Getfield field stk by auto
      next
        case (Putfield F C)
        with app stk reg Φ obtain v ref vT stk' fm where
          field: "P  C sees F:vT (fm) in C" and
          stk:   "stk = v # ref # stk'" and
          confv: "P,h  v :≤ vT" and
          confr: "P,h  ref :≤ Class C"
          by(fastforce simp add: list_all2_Cons2)
        from confr have is_Ref: "is_Ref ref"
          by(cases ref)(auto simp add: is_Ref_def conf_def)
        moreover {
          assume "ref  Null" 
          with confr field is_Ref wf
          have "U. typeof_addr h (the_Addr ref) = Some U  P  class_type_of U * C"
            by (auto dest: non_npD2)
        }
        ultimately show ?thesis using Putfield field stk confv by auto
      next
        case (CAS F C)
        with app stk reg Φ obtain v v' v'' T' stk' fm where
          field: "P  C sees F:T' (fm) in C" and
          stk:   "stk = v'' # v' # v # stk'" and
          confv: "P,h  v' :≤ T'" "P,h  v'' :≤ T'" and
          confr: "P,h  v :≤ Class C" and vol: "volatile fm"
          by(fastforce simp add: list_all2_Cons2)
        from confr have is_Ref: "is_Ref v"
          by(cases v)(auto simp add: is_Ref_def conf_def)
        moreover {
          assume "v  Null" 
          with confr field is_Ref wf
          have "U. typeof_addr h (the_Addr v) = Some U  P  class_type_of U * C"
            by (auto dest: non_npD2)
        }
        ultimately show ?thesis using CAS field stk confv vol by auto
      next
        case (Invoke M' n)
        with app have n: "n < size ST" by simp
        
        from stk have [simp]: "size stk = size ST" by (rule list_all2_lengthD)
        
        { assume "stk!n = Null" with n Invoke have ?thesis by simp }
        moreover { 
          assume "ST!n = NT"
          with n stk have "stk!n = Null" by (auto simp: list_all2_conv_all_nth)
          with n Invoke have ?thesis by simp
        }
        moreover {
          assume Null: "stk!n  Null" and NT: "ST!n  NT"
          
          from NT app Invoke
          obtain D D' Ts T m
            where D: "class_type_of' (ST!n) = D"
            and M': "P  D sees M': TsT = m in D'"
            and Ts: "P  rev (take n ST) [≤] Ts" by auto
          from stk n have "P,h  stk!n :≤ ST!n" 
            by (auto simp: list_all2_conv_all_nth)
          with Null D obtain a U where 
            [simp]: "stk!n = Addr a" "typeof_addr h a = Some U" and UsubSTn: "P  ty_of_htype U  ST!n"
            by(cases "stk ! n")(auto simp add: conf_def widen_Class)
          from D UsubSTn obtain C'
            where U: "class_type_of' (ty_of_htype U) = C'" and "P  C' * D"
            by(rule widen_is_class_type_of) simp

          from P  C' * D wf M' obtain m' Ts' T' D'' where 
            C': "P  C' sees M': Ts'T' = m' in D''" and
            Ts': "P  Ts [≤] Ts'"
            by (auto dest!: sees_method_mono)

          from stk have "P,h  take n stk [:≤] take n ST" ..
          hence "P,h  rev (take n stk) [:≤] rev (take n ST)" ..
          also note Ts also note Ts'
          finally have "P,h  rev (take n stk) [:≤] Ts'" .
          hence ?thesis using Invoke Null n C' U
            by (auto simp add: is_Ref_def2 has_methodI intro: sees_wf_native[OF wf]) }
        ultimately show ?thesis by blast      
      next
        case Return with stk app Φ meth frames 
        show ?thesis by (fastforce simp add: has_methodI list_all2_Cons2)
      next
        case ThrowExc with stk app Φ meth frames show ?thesis
          by(auto 4 3 simp add: xcpt_app_def conf_def list_all2_Cons2 intro!: is_RefI intro: widen_trans[OF _ widen_subcls])
      next
        case (BinOpInstr bop) with stk app Φ meth frames
        show ?thesis by(auto simp add: conf_def list_all2_Cons2)(force dest: WTrt_binop_widen_mono)
      qed (auto simp add: list_all2_lengthD list_all2_Cons2)
      thus "check P σ" using meth pc mxs by (simp add: check_def has_methodI)
    next
      case (Some a)
      with confxcp obtain D where "typeof_addr h a = Class_type D"
        by(auto simp add: check_xcpt_def)
      moreover from stk have "length stk = length ST" by(rule list_all2_lengthD)
      ultimately show ?thesis using meth pc mxs Some confxcp app
        using match_is_relevant[of P D ins pc pc xt]
        by(auto simp add: check_def has_methodI check_xcpt_def xcpt_app_def dest: bspec)
    qed
  qed
  thus "exec_d P t σ  TypeError" ..
qed

lemma welltyped_commute:
  "wf_jvm_progΦ P; Φ  t:σ   P,t  Normal σ -ta-jvmd→ Normal σ' = P,t  σ -ta-jvm→ σ'"
apply(rule iffI)
 apply(erule exec_1_d.cases, simp, fastforce simp add: exec_d_def exec_1_iff split: if_split_asm)
by(auto dest!: no_type_error intro!: exec_1_d.intros simp add: exec_d_def exec_1_iff split: if_split_asm)

end

lemma (in JVM_conf_read) BV_correct_d_1:
  " wf_jvm_progΦ P; P,t  Normal σ -ta-jvmd→ Normal σ'; Φ  t:σ    Φ  t:σ' "
  unfolding welltyped_commute
  by(rule BV_correct_1)


lemma not_TypeError_eq [iff]:
  "x  TypeError = (t. x = Normal t)"
  by (cases x) auto

end  

Theory BVProgressThreaded

(*  Title:      JinjaThreads/BV/JVMDeadlocked.thy
    Author:     Andreas Lochbihler
*)

section ‹Progress result for both of the multithreaded JVMs›

theory BVProgressThreaded
imports
  "../Framework/FWProgress"
  "../Framework/FWLTS"
  BVNoTypeError
  "../JVM/JVMThreaded"
begin

lemma (in JVM_heap_conf_base') mexec_eq_mexecd:
  " wf_jvm_progΦ P; Φ  t: (xcp, h, frs)    mexec P t ((xcp, frs), h) = mexecd P t ((xcp, frs), h)"
apply(auto intro!: ext)
 apply(unfold exec_1_iff)
 apply(drule no_type_error)
  apply(assumption)
 apply(clarify)
 apply(rule exec_1_d_NormalI)
  apply(assumption)
 apply(simp add: exec_d_def split: if_split_asm)
apply(erule jvmd_NormalE, auto)
done

(* conformance lifted to multithreaded case *)

context JVM_heap_conf_base begin

abbreviation 
  correct_state_ts :: "tyP  ('addr,'thread_id,'addr jvm_thread_state) thread_info  'heap  bool"
where
  "correct_state_ts Φ  ts_ok (λt (xcp, frstls) h. Φ  t: (xcp, h, frstls) )"

lemma correct_state_ts_thread_conf:
  "correct_state_ts Φ (thr s) (shr s)  thread_conf P (thr s) (shr s)"
by(erule ts_ok_mono)(auto simp add: correct_state_def)

lemma invoke_new_thread:
  assumes "wf_jvm_progΦ P"
  and "P  C sees M:TsT=(mxs,mxl0,ins,xt) in C"
  and "ins ! pc = Invoke Type.start 0"
  and "P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M"
  and "Φ  t: (None, h, (stk, loc, C, M, pc) # frs) "
  and "typeof_addr h (thread_id2addr a) = Class_type D"
  and "P  D * Thread"
  and "P  D sees run:[]Void=(mxs', mxl0', ins',xt') in D'"
  shows "Φ  a: (None, h, [([], Addr (thread_id2addr a) # replicate mxl0' undefined_value, D', run, 0)]) "
proof -
  from Φ  t: (None, h, (stk, loc, C, M, pc) # frs) 
  have "hconf h" and "preallocated h" by(simp_all add: correct_state_def)
  moreover
  from P  D sees run:[]Void=(mxs', mxl0', ins',xt') in D'
  have "P  D' sees run:[]Void=(mxs', mxl0', ins',xt') in D'"
    by(rule sees_method_idemp)
  with ‹wf_jvm_progΦ P
  have "wt_start P D' [] mxl0' (Φ D' run)" and "ins'  []"
    by(auto dest: wt_jvm_prog_impl_wt_start)
  then obtain LT' where LT': "Φ D' run ! 0 = Some ([], LT')"
    by (clarsimp simp add: wt_start_def defs1 sup_state_opt_any_Some)
  moreover
  have "conf_f P h ([], LT') ins' ([], Addr (thread_id2addr a) # replicate mxl0' undefined_value, D', run, 0)"
  proof -
    let ?LT = "OK (Class D') # (replicate mxl0' Err)"
    have "P,h  replicate mxl0' undefined_value [:≤] replicate mxl0' Err" by simp
    also from P  D sees run:[]Void=(mxs', mxl0', ins',xt') in D'
    have "P  D * D'" by(rule sees_method_decl_above)
    with typeof_addr h (thread_id2addr a) = Class_type D
    have "P,h  Addr (thread_id2addr a) :≤ Class D'"
      by(simp add: conf_def)
    ultimately have "P,h  Addr (thread_id2addr a) # replicate mxl0' undefined_value [:≤] ?LT" by(simp)
    also from ‹wt_start P D' [] mxl0' (Φ D' run) LT'
    have "P   [≤] LT'" by(simp add: wt_start_def)
    finally have "P,h  Addr (thread_id2addr a) # replicate mxl0' undefined_value [:≤] LT'" .
    with ins'  [] show ?thesis by(simp add: conf_f_def)
  qed
  moreover from typeof_addr h (thread_id2addr a) = Class_type D P  D * Thread›
  have "P,h  a √t" by(rule tconfI)
  ultimately show ?thesis using P  D' sees run:[]Void=(mxs', mxl0', ins',xt') in D'
    by(fastforce simp add: correct_state_def)
qed

lemma exec_new_threadE:
  assumes "wf_jvm_progΦ P"
  and "P,t  Normal σ -ta-jvmd→ Normal σ'"
  and "Φ  t: σ "
  and "tat  []"
  obtains h frs a stk loc C M pc Ts T mxs mxl0 ins xt M' n Ta ta' va  Us Us' U m' D'
  where "σ = (None, h, (stk, loc, C, M, pc) # frs)"
  and "(ta, σ')  exec P t (None, h, (stk, loc, C, M, pc) # frs)"
  and "P  C sees M: TsT = (mxs, mxl0, ins, xt) in C"
  and "stk ! n = Addr a"
  and "ins ! pc = Invoke M' n"
  and "n < length stk"
  and "typeof_addr h a = Ta"
  and "is_native P Ta M'"
  and "ta = extTA2JVM P ta'"
  and "σ' = extRet2JVM n m' stk loc C M pc frs va"
  and "(ta', va, m')  red_external_aggr P t a M' (rev (take n stk)) h"
  and "map typeofh (rev (take n stk)) = map Some Us"
  and "P  class_type_of Ta sees M':Us'U = Native in D'"
  and "D'M'(Us') :: U"
  and "P  Us [≤] Us'"
proof -
  from P,t  Normal σ -ta-jvmd→ Normal σ' obtain h f Frs xcp
    where check: "check P σ"
    and exec: "(ta, σ')  exec P t σ"
    and [simp]: "σ = (xcp, h, f # Frs)"
    by(rule jvmd_NormalE)
  obtain stk loc C M pc where [simp]: "f = (stk, loc, C, M, pc)"
    by(cases f, blast)
  from tat  [] exec have [simp]: "xcp = None" by(cases xcp) auto
  from Φ  t: σ 
  obtain Ts T mxs mxl0 ins xt ST LT 
    where "hconf h" "preallocated h"
    and sees: "P  C sees M: TsT = (mxs, mxl0, ins, xt) in C"
    and "Φ C M ! pc = (ST, LT)"
    and "conf_f P h (ST, LT) ins (stk, loc, C, M, pc)"
    and "conf_fs P h Φ M (length Ts) T Frs"
    by(fastforce simp add: correct_state_def)
  from check Φ C M ! pc = (ST, LT) sees
  have checkins: "check_instr (ins ! pc) P h stk loc C M pc Frs"
    by(clarsimp simp add: check_def)
  from sees tat  [] exec obtain M' n where [simp]: "ins ! pc = Invoke M' n"
    by(cases "ins ! pc", auto split: if_split_asm simp add: split_beta ta_upd_simps)
  from ‹wf_jvm_progΦ P obtain wfmd where wfp: "wf_prog wfmd P" by(auto dest: wt_jvm_progD)
  
  from checkins have "n < length stk" "is_Ref (stk ! n)" by auto
  moreover from exec sees tat  [] have "stk ! n  Null" by auto
  with ‹is_Ref (stk ! n) obtain a where "stk ! n = Addr a"
    by(auto simp add: is_Ref_def elim: is_AddrE)
  moreover with checkins obtain Ta where Ta: "typeof_addr h a = Ta" by(fastforce)
  moreover with checkins exec sees n < length stk tat  [] stk ! n = Addr a
  obtain Us Us' U D' where "map typeofh (rev (take n stk)) = map Some Us"
    and "P  class_type_of Ta sees M':Us'U = Native in D'" and "D'M'(Us') :: U"
    and "P  Us [≤] Us'"
    by(auto simp add: confs_conv_map min_def split_beta has_method_def external_WT'_iff split: if_split_asm)
  moreover with typeof_addr h a = Ta n < length stk exec sees stk ! n = Addr a
  obtain ta' va h' where "ta = extTA2JVM P ta'" "σ' = extRet2JVM n h' stk loc C M pc Frs va"
    "(ta', va, h')  red_external_aggr P t a M' (rev (take n stk)) h"
    by(fastforce simp add: min_def)
  ultimately show thesis using exec sees 
    by-(rule that, auto intro!: is_native.intros)
qed

end

context JVM_conf_read begin

lemma correct_state_new_thread:
  assumes wf: "wf_jvm_progΦ P"
  and red: "P,t  Normal σ -ta-jvmd→ Normal σ'"
  and cs: "Φ  t: σ "
  and nt: "NewThread t'' (xcp, frs) h''  set tat"
  shows "Φ  t'': (xcp, h'', frs) "
proof -
  from wf obtain wt where wfp: "wf_prog wt P" by(blast dest: wt_jvm_progD)
  from nt have "tat  []" by auto
  with wf red cs
  obtain h Frs a stk loc C M pc Ts T mxs mxl0 ins xt M' n Ta ta' va h' Us Us' U D'
    where [simp]: "σ = (None, h, (stk, loc, C, M, pc) # Frs)"
    and exec: "(ta, σ')  exec P t (None, h, (stk, loc, C, M, pc) # Frs)"
    and sees: "P  C sees M: TsT = (mxs, mxl0, ins, xt) in C"
    and [simp]: "stk ! n = Addr a"
    and [simp]: "ins ! pc = Invoke M' n"
    and n: "n < length stk"
    and Ta: "typeof_addr h a = Ta"
    and iec: "is_native P Ta M'"
    and ta: "ta = extTA2JVM P ta'"
    and σ': "σ' = extRet2JVM n h' stk loc C M pc Frs va"
    and rel: "(ta', va, h')  red_external_aggr P t a M' (rev (take n stk)) h"
    and Us: "map typeofh (rev (take n stk)) = map Some Us"
    and wtext: "P  class_type_of Ta sees M':Us'U = Native in D'" "D'M'(Us') :: U"
    and sub: "P  Us [≤] Us'"
    by(rule exec_new_threadE)
  from cs have hconf: "hconf h" and preh: "preallocated h"
    and tconf: "P,h  t √t" by(auto simp add: correct_state_def)
  from Ta Us wtext sub have wtext': "P,h  aM'(rev (take n stk)) : U"
    by(auto intro!: external_WT'.intros)
  from rel have red: "P,t  aM'(rev (take n stk)), h -ta'→ext va, h'"
    by(unfold WT_red_external_list_conv[OF wfp wtext' tconf])
  from ta nt obtain D M'' a' where nt': "NewThread t'' (D, M'', a') h''  set ta't"
    "(xcp, frs) = extNTA2JVM P (D, M'', a')" by auto
  with red have [simp]: "h'' = h'" by-(rule red_ext_new_thread_heap)
  from red_external_new_thread_sub_thread[OF red nt'(1)]
  have h't'': "typeof_addr h' a' = Class_type D" "P  D * Thread" and [simp]: "M'' = run" by auto
  from red_external_new_thread_exists_thread_object[OF red nt'(1)] 
  have tconf': "P,h'  t'' √t" by(auto intro: tconfI)
  from sub_Thread_sees_run[OF wfp P  D * Thread›] obtain mxs' mxl0' ins' xt' D'
    where seesrun: "P  D sees run: []Void = (mxs', mxl0', ins', xt') in D'" by auto
  with nt' ta nt have "xcp = None" "frs = [([],Addr a' # replicate mxl0' undefined_value,D',run,0)]"
    by(auto simp add: extNTA2JVM_def split_beta)
  moreover
  have "Φ  t'': (None, h', [([], Addr a' # replicate mxl0' undefined_value, D', run, 0)]) "
  proof -
    from red wtext' hconf h have "hconf h'" 
      by(rule external_call_hconf)
    moreover from red have "h  h'" by(rule red_external_hext)
    with preh have "preallocated h'" by(rule preallocated_hext)
    moreover from seesrun
    have seesrun': "P  D' sees run: []Void = (mxs', mxl0', ins', xt') in D'"
      by(rule sees_method_idemp)
    moreover with ‹wf_jvm_progΦ P
    obtain "wt_start P D' [] mxl0' (Φ D' run)" "ins'  []"
      by (auto dest: wt_jvm_prog_impl_wt_start)    
    then obtain LT' where "Φ D' run ! 0 = Some ([], LT')"
      by (clarsimp simp add: wt_start_def defs1 sup_state_opt_any_Some)
    moreover
    have "conf_f P h' ([], LT') ins' ([], Addr a' # replicate mxl0' undefined_value, D', run, 0)"
    proof -
      let ?LT = "OK (Class D') # (replicate mxl0' Err)"
      from seesrun have "P  D * D'" by(rule sees_method_decl_above)
      hence "P,h'  Addr a' # replicate mxl0' undefined_value [:≤] ?LT"
        using h't'' by(simp add: conf_def)
      also from ‹wt_start P D' [] mxl0' (Φ D' run) Φ D' run ! 0 = Some ([], LT')
      have "P  ?LT [≤] LT'" by(simp add: wt_start_def)
      finally have "P,h'  Addr a' # replicate mxl0' undefined_value [:≤] LT'" .
      with ins'  [] show ?thesis by(simp add: conf_f_def)
    qed
    ultimately show ?thesis using tconf' by(fastforce simp add: correct_state_def)
  qed
  ultimately show ?thesis by(clarsimp)
qed

lemma correct_state_heap_change:
  assumes wf: "wf_jvm_progΦ P"
  and red: "P,t  Normal (xcp, h, frs) -ta-jvmd→ Normal (xcp', h', frs')"
  and cs: "Φ  t: (xcp, h, frs) "
  and cs'': "Φ  t'': (xcp'', h, frs'') "
  shows "Φ  t'': (xcp'', h', frs'') "
proof(cases xcp)
  case None
  from cs have "P,h  t √t" by(simp add: correct_state_def)
  with red have "hext h h'" by (auto intro: exec_1_d_hext simp add: tconf_def)
  from ‹wf_jvm_progΦ P cs red have "Φ  t: (xcp', h', frs') "
    by(auto elim!: jvmd_NormalE intro: BV_correct_1 simp add: exec_1_iff)
  from cs'' have "P,h  t'' √t" by(simp add: correct_state_def)
  with h  h' have tconf': "P,h'  t'' √t" by-(rule tconf_hext_mono)

  from Φ  t: (xcp', h', frs') 
  have hconf': "hconf h'" "preallocated h'" by(simp_all add: correct_state_def)

  show ?thesis
  proof(cases frs'')
    case Nil thus ?thesis using tconf' hconf' by(simp add: correct_state_def)
  next
    case (Cons f'' Frs'')
    obtain stk'' loc'' C0'' M0'' pc''
      where "f'' = (stk'', loc'', C0'', M0'', pc'')"
      by(cases f'', blast)
    with frs'' = f'' # Frs'' cs''
    obtain Ts'' T'' mxs'' mxl0'' ins'' xt'' ST'' LT'' 
      where "hconf h"
      and sees'': "P  C0'' sees M0'': Ts''T'' = (mxs'', mxl0'', ins'', xt'') in C0''"
      and "Φ C0'' M0'' ! pc'' = (ST'', LT'')"
      and "conf_f P h (ST'', LT'') ins'' (stk'', loc'', C0'', M0'', pc'')"
      and "conf_fs P h Φ M0'' (length Ts'') T'' Frs''"
      by(fastforce simp add: correct_state_def)
    
    show ?thesis using Cons Φ  t'': (xcp'', h, frs'')  ‹hext h h' hconf' tconf'
      apply(cases xcp'')
      apply(auto simp add: correct_state_def)
      apply(blast dest: hext_objD intro: conf_fs_hext conf_f_hext)+
      done
  qed
next
  case (Some a)
  with P,t  Normal (xcp, h, frs) -ta-jvmd→ Normal (xcp', h', frs')
  have "h = h'" by(auto elim!: jvmd_NormalE)
  with Φ  t'': (xcp'', h, frs'')  show ?thesis by simp
qed

lemma lifting_wf_correct_state_d:
  "wf_jvm_progΦ P  lifting_wf JVM_final (mexecd P) (λt (xcp, frs) h. Φ  t: (xcp, h, frs) )"
by(unfold_locales)(auto intro: BV_correct_d_1 correct_state_new_thread correct_state_heap_change)

lemma lifting_wf_correct_state:
  assumes wf: "wf_jvm_progΦ P"
  shows "lifting_wf JVM_final (mexec P) (λt (xcp, frs) h. Φ  t: (xcp, h, frs) )"
proof(unfold_locales)
  fix t x m ta x' m'
  assume "mexec P t (x, m) ta (x', m')"
    and "(λ(xcp, frs) h. Φ  t: (xcp, h, frs) ) x m"
  with wf show "(λ(xcp, frs) h. Φ  t: (xcp, h, frs) ) x' m'"
    by(cases x)(cases x', simp add: welltyped_commute[symmetric, OF ‹wf_jvm_progΦ P], rule BV_correct_d_1)
next
  fix t x m ta x' m' t'' x''
  assume "mexec P t (x, m) ta (x', m')"
    and "(λ(xcp, frs) h. Φ  t: (xcp, h, frs) ) x m"
    and "NewThread t'' x'' m'  set tat"
  with wf show "(λ(xcp, frs) h. Φ  t'': (xcp, h, frs) ) x'' m'"
    apply(cases x, cases x', cases x'', clarify, unfold welltyped_commute[symmetric, OF ‹wf_jvm_progΦ P])
    by(rule correct_state_new_thread)
next
  fix t x m ta x' m' t'' x''
  assume "mexec P t (x, m) ta (x', m')"
    and "(λ(xcp, frs) h. Φ  t: (xcp, h, frs) ) x m"
    and "(λ(xcp, frs) h. Φ  t'': (xcp, h, frs) ) x'' m"
  with wf show "(λ(xcp, frs) h. Φ  t'': (xcp, h, frs) ) x'' m'"
    by(cases x)(cases x', cases x'', clarify, unfold welltyped_commute[symmetric, OF ‹wf_jvm_progΦ P], rule correct_state_heap_change)
qed

lemmas preserves_correct_state = FWLiftingSem.lifting_wf.RedT_preserves[OF lifting_wf_correct_state]
lemmas preserves_correct_state_d = FWLiftingSem.lifting_wf.RedT_preserves[OF lifting_wf_correct_state_d]

end

context JVM_heap_conf_base begin

definition correct_jvm_state :: "tyP  ('addr,'thread_id,'addr jvm_thread_state,'heap,'addr) state set"
where
  "correct_jvm_state Φ
  = {s. correct_state_ts Φ (thr s) (shr s)  lock_thread_ok (locks s) (thr s)}"

end

context JVM_heap_conf begin

lemma correct_jvm_state_initial:
  assumes wf: "wf_jvm_progΦ P"
  and wf_start: "wf_start_state P C M vs"
  shows "JVM_start_state P C M vs  correct_jvm_state Φ"
proof -
  from wf_start obtain Ts T m D 
    where "start_heap_ok" and "P  C sees M:TsT = m in D"
    and "P,start_heap  vs [:≤] Ts" by cases
  with wf BV_correct_initial[OF wf this] show ?thesis
    by(cases m)(auto simp add: correct_jvm_state_def start_state_def JVM_start_state'_def intro: lock_thread_okI ts_okI split: if_split_asm)
qed

end

context JVM_conf_read begin

lemma invariant3p_correct_jvm_state_mexecdT:
  assumes wf:  "wf_jvm_progΦ P"
  shows "invariant3p (mexecdT P) (correct_jvm_state Φ)"
unfolding correct_jvm_state_def
apply(rule invariant3pI)
apply safe
 apply(erule (1) lifting_wf.redT_preserves[OF lifting_wf_correct_state_d[OF wf]])
apply(erule (1) execd_mthr.redT_preserves_lock_thread_ok)
done

lemma invariant3p_correct_jvm_state_mexecT:
  assumes wf:  "wf_jvm_progΦ P"
  shows "invariant3p (mexecT P) (correct_jvm_state Φ)"
unfolding correct_jvm_state_def
apply(rule invariant3pI)
apply safe
 apply(erule (1) lifting_wf.redT_preserves[OF lifting_wf_correct_state[OF wf]])
apply(erule (1) exec_mthr.redT_preserves_lock_thread_ok)
done

lemma correct_jvm_state_preserved:
  assumes wf: "wf_jvm_progΦ P"
  and correct: "s  correct_jvm_state Φ"
  and red: "P  s -▹ttasjvm* s'"
  shows "s'  correct_jvm_state Φ"
using wf red correct unfolding exec_mthr.RedT_def
by(rule invariant3p_rtrancl3p[OF invariant3p_correct_jvm_state_mexecT])

theorem jvm_typesafe:
  assumes wf: "wf_jvm_progΦ P"
  and start: "wf_start_state P C M vs"
  and exec: "P  JVM_start_state P C M vs -▹ttasjvm* s'"
  shows "s'  correct_jvm_state Φ"
by(rule correct_jvm_state_preserved[OF wf _ exec])(rule correct_jvm_state_initial[OF wf start])

end


declare (in JVM_typesafe) split_paired_Ex [simp del]

context JVM_heap_conf_base' begin 

lemma execd_NewThread_Thread_Object:
  assumes wf: "wf_jvm_progΦ P"
  and conf: "Φ  t': σ "
  and red: "P,t'  Normal σ -ta-jvmd→ Normal σ'"
  and nt: "NewThread t x m  set tat"
  shows "C. typeof_addr (fst (snd σ')) (thread_id2addr t) = Class_type C  P  Class C  Class Thread"
proof -
  from wf obtain wfmd where wfp: "wf_prog wfmd P" by(blast dest: wt_jvm_progD)
  from red obtain h f Frs xcp
    where check: "check P σ" 
    and exec: "(ta, σ')  exec P t' σ" 
    and [simp]: "σ = (xcp, h, f # Frs)"
    by(rule jvmd_NormalE)
  obtain xcp' h' frs' where [simp]: "σ' = (xcp', h', frs')" by(cases σ', auto)
  obtain stk loc C M pc where [simp]: "f = (stk, loc, C, M, pc)" by(cases f, blast)
  from exec nt have [simp]: "xcp = None" by(cases xcp, auto)
  from Φ  t': σ  obtain Ts T mxs mxl0 ins xt ST LT 
    where "hconf h"
    and "P,h  t' √t"
    and sees: "P  C sees M: TsT = (mxs, mxl0, ins, xt) in C"
    and "Φ C M ! pc = (ST, LT)"
    and "conf_f P h (ST, LT) ins (stk, loc, C, M, pc)"
    and "conf_fs P h Φ M (length Ts) T Frs"
    by(fastforce simp add: correct_state_def)
  from wf red conf nt
  obtain h frs a stk loc C M pc M' n ta' va h'
    where ha: "typeof_addr h a  None" and ta: "ta = extTA2JVM P ta'"
    and σ': "σ' = extRet2JVM n h' stk loc C M pc frs va"
    and rel: "(ta', va, h')  red_external_aggr P t' a M' (rev (take n stk)) h"
    by -(erule (2) exec_new_threadE, fastforce+)
  from nt ta obtain x' where "NewThread t x' m  set ta't" by auto
  from red_external_aggr_new_thread_exists_thread_object[OF rel ha this] σ'
  show ?thesis by(cases va) auto
qed

lemma mexecdT_NewThread_Thread_Object:
  " wf_jvm_progΦ P; correct_state_ts Φ (thr s) (shr s); P  s -t'tajvmd s'; NewThread t x m  set tat 
   C. typeof_addr (shr s') (thread_id2addr t) = Class_type C  P  C * Thread"
apply(frule correct_state_ts_thread_conf)
apply(erule execd_mthr.redT.cases)
 apply(hypsubst)
 apply(frule (2) execd_tconf.redT_updTs_preserves[where ln'="redT_updLns (locks s) t' no_wait_locks tal"])
  apply clarsimp
 apply(clarsimp)
 apply(drule execd_NewThread_Thread_Object)
    apply(drule (1) ts_okD)
    apply(fastforce)
   apply(assumption)
  apply(fastforce)
 apply(clarsimp)
apply(simp)
done

end

context JVM_heap begin

lemma exec_ta_satisfiable:
  assumes "P,t  s -ta-jvm→ s'"
  shows "s. exec_mthr.actions_ok s t ta"
proof -
  obtain xcp h frs where [simp]: "s = (xcp, h, frs)" by(cases s)
  from assms obtain stk loc C M pc frs' where [simp]: "frs = (stk, loc, C, M, pc) # frs'"
    by(cases frs)(auto simp add: exec_1_iff)
  show ?thesis
  proof(cases xcp)
    case Some with assms show ?thesis by(auto simp add: exec_1_iff lock_ok_las_def finfun_upd_apply split_paired_Ex)
  next
    case None
    with assms show ?thesis
      apply(cases "instrs_of P C M ! pc")
      apply(auto simp add: exec_1_iff lock_ok_las_def finfun_upd_apply split_beta final_thread.actions_ok_iff split: if_split_asm dest: red_external_aggr_ta_satisfiable[where final=JVM_final])
      apply(fastforce simp add: final_thread.actions_ok_iff lock_ok_las_def dest: red_external_aggr_ta_satisfiable[where final=JVM_final])
      apply(fastforce simp add: finfun_upd_apply intro: exI[where x="K$ None"] exI[where x="K$ (t, 0)"] may_lock.intros)+
      done
  qed
qed

end

context JVM_typesafe begin

lemma execd_wf_progress:
  assumes wf: "wf_jvm_progΦ P"
  shows "progress JVM_final (mexecd P) (execd_mthr.wset_Suspend_ok P (correct_jvm_state Φ))"
  (is "progress _ _ ?wf_state")
proof
  {
    fix s t x ta x' m' w
    assume mexecd: "mexecd P t (x, shr s) ta (x', m')"
      and Suspend: "Suspend w  set taw"
    from mexecd_Suspend_Invoke[OF mexecd Suspend]
    show "¬ JVM_final x'" by auto
  }
  note Suspend_final = this
  {
    fix s
    assume s: "s  ?wf_state"
    hence "lock_thread_ok (locks s) (thr s)"
      by(auto dest: execd_mthr.wset_Suspend_okD1 simp add: correct_jvm_state_def)
    moreover
    have "exec_mthr.wset_final_ok (wset s) (thr s)"
    proof(rule exec_mthr.wset_final_okI)
      fix t w
      assume "wset s t = w"
      from execd_mthr.wset_Suspend_okD2[OF s this]
      obtain x0 ta x m1 w' ln'' and s0 :: "('addr, 'thread_id, 'addr option × 'addr frame list, 'heap, 'addr) state"
        where mexecd: "mexecd P t (x0, shr s0) ta (x, m1)"
        and Suspend: "Suspend w'  set taw" 
        and tst: "thr s t = (x, ln'')" by blast
      from Suspend_final[OF mexecd Suspend] tst
      show " x ln. thr s t = (x, ln)  ¬ JVM_final x" by blast
    qed
    ultimately show "lock_thread_ok (locks s) (thr s)  exec_mthr.wset_final_ok (wset s) (thr s)" ..
  }
next
  fix s t x ta x' m'
  assume wfs: "s  ?wf_state"
    and "thr s t = (x, no_wait_locks)"
    and "mexecd P t (x, shr s) ta (x', m')"
    and wait: "¬ waiting (wset s t)"
  moreover obtain ls ts h ws "is" where s [simp]: "s = (ls, (ts, h), ws, is)" by(cases s) fastforce
  ultimately have "ts t = (x, no_wait_locks)" "mexecd P t (x, h) ta (x', m')" by auto
  from wfs have "correct_state_ts Φ ts h" by(auto dest: execd_mthr.wset_Suspend_okD1 simp add: correct_jvm_state_def)
  from wf obtain wfmd where wfp: "wf_prog wfmd P" by(auto dest: wt_jvm_progD)
    
  from ts t = (x, no_wait_locks) ‹mexecd P t (x, h) ta (x', m')
  obtain xcp frs xcp' frs'
    where "P,t  Normal (xcp, h, frs) -ta-jvmd→ Normal (xcp', m', frs')"
    and [simp]: "x = (xcp, frs)" "x' = (xcp', frs')"
    by(cases x, auto)
  then obtain f Frs
    where check: "check P (xcp, h, f # Frs)"
    and [simp]: "frs = f # Frs"
    and exec: "(ta, xcp', m', frs')  exec P t (xcp, h, f # Frs)"
    by(auto elim: jvmd_NormalE)
  with ts t = (x, no_wait_locks) ‹correct_state_ts Φ ts h
  have correct: "Φ  t: (xcp, h, f # Frs) " by(auto dest: ts_okD)
  obtain stk loc C M pc where f [simp]: "f = (stk, loc, C, M, pc)" by (cases f)
  from correct obtain Ts T mxs mxl0 ins xt ST LT
    where hconf: "hconf h"
    and tconf: "P, h  t √t"
    and sees: "P  C sees M:TsT = (mxs, mxl0, ins, xt) in C"
    and wt: "Φ C M ! pc = (ST, LT)"
    and conf_f: "conf_f P h (ST, LT) ins (stk, loc, C, M, pc)"
    and confs: "conf_fs P h Φ M (length Ts) T Frs"
    and confxcp: "conf_xcp P h xcp (ins ! pc)"
    and preh: "preallocated h"
    by(fastforce simp add: correct_state_def)
  
  have "ta' σ'. P,t  Normal (xcp, h, (stk, loc, C, M, pc) # Frs) -ta'-jvmd→ Normal σ' 
                 (final_thread.actions_ok JVM_final (ls, (ts, h), ws, is) t ta' 
                  final_thread.actions_ok' (ls, (ts, h), ws, is) t ta'  final_thread.actions_subset ta' ta)"
  proof(cases "final_thread.actions_ok' (ls, (ts, h), ws, is) t ta")
    case True
    have "final_thread.actions_subset ta ta" ..
    with True P,t  Normal (xcp, h, frs) -ta-jvmd→ Normal (xcp', m', frs')
    show ?thesis by auto
  next
    case False
    note naok = this
    have ws: "wset s t = None  
              (n a T w. ins ! pc = Invoke wait n  stk ! n = Addr a  typeof_addr h a = T  is_native P T wait  wset s t = PostWS w  xcp = None)"
    proof(cases "wset s t")
      case None thus ?thesis ..
    next
      case (Some w)
      from execd_mthr.wset_Suspend_okD2[OF wfs this] ts t = (x, no_wait_locks)
      obtain xcp0 frs0 h0 ta0 w' s1 tta1
        where red0: "mexecd P t ((xcp0, frs0), h0) ta0 ((xcp, frs), shr s1)"
        and Suspend: "Suspend w'  set ta0w"
        and s1: "P  s1 -▹tta1jvmd* s"
        by auto
      from mexecd_Suspend_Invoke[OF red0 Suspend] sees
      obtain n a T where [simp]: "ins ! pc = Invoke wait n" "xcp = None" "stk ! n = Addr a"
        and type: "typeof_addr h0 a = T"
        and iec: "is_native P T wait"
        by(auto simp add: is_native.simps) blast
      
      from red0 have "h0  shr s1" by(auto dest: exec_1_d_hext)
      also from s1 have "shr s1  shr s" by(rule Execd_hext)
      finally have "typeof_addr (shr s) a = T" using type
        by(rule typeof_addr_hext_mono)
      moreover from Some wait s obtain w' where "ws t = PostWS w'"
        by(auto simp add: not_waiting_iff)
      ultimately show ?thesis using iec s by auto
    qed

    from ws naok exec sees
    show ?thesis
    proof(cases "ins ! pc")
      case (Invoke M' n)
      from ws Invoke check exec sees naok obtain a Ts U Ta Us D D'
        where a: "stk ! n = Addr a"
        and n: "n < length stk"
        and Ta: "typeof_addr h a = Ta"
        and wtext: "P  class_type_of Ta sees M':UsU = Native in D'" "D'M'(Us)::U"
        and sub: "P  Ts [≤] Us"
        and Ts: "map typeofh (rev (take n stk)) = map Some Ts"
        and [simp]: "xcp = None"
        apply(cases xcp)
        apply(simp add: is_Ref_def has_method_def external_WT'_iff check_def lock_ok_las'_def confs_conv_map split_beta split: if_split_asm option.splits)
        apply(auto simp add: lock_ok_las'_def)[2]
        apply(fastforce simp add: is_native.simps lock_ok_las'_def dest: sees_method_fun)+
        done
      from exec Ta n a sees Invoke wtext obtain ta' va m''
        where exec': "(ta', va, m'')  red_external_aggr P t a M' (rev (take n stk)) h"
        and ta: "ta = extTA2JVM P ta'"
        and va: "(xcp', m', frs') = extRet2JVM n m'' stk loc C M pc Frs va"
        by(auto)
      from va have [simp]: "m'' = m'" by(cases va) simp_all
      from Ta Ts wtext sub have wtext': "P,h  aM'(rev (take n stk)) : U"
        by(auto intro!: external_WT'.intros simp add: is_native.simps)
      with wfp exec' tconf have red: "P,t  aM'(rev (take n stk)), h -ta'→ext va, m'"
        by(simp add: WT_red_external_list_conv)
      from ws Invoke have "wset s t = None  M' = wait  (w. wset s t = PostWS w)" by auto
      with wfp red tconf hconf obtain ta'' va' h''
        where red': "P,t  aM'(rev (take n stk)),h -ta''→ext va',h''"
        and ok': "final_thread.actions_ok JVM_final s t ta''  final_thread.actions_ok' s t ta''  final_thread.actions_subset ta'' ta'"
        by(rule red_external_wf_red)
      from red' a n Ta Invoke sees wtext
      have "(extTA2JVM P ta'', extRet2JVM n h'' stk loc C M pc Frs va')  exec P t (xcp, h, f # Frs)" 
        by(auto intro: red_external_imp_red_external_aggr)
      with check have "P,t  Normal (xcp, h, (stk, loc, C, M, pc) # Frs) -extTA2JVM P ta''-jvmd→ Normal (extRet2JVM n h'' stk loc C M pc Frs va')"
        by -(rule exec_1_d.exec_1_d_NormalI, auto simp add: exec_d_def)
      moreover from ok' ta
      have "final_thread.actions_ok JVM_final (ls, (ts, h), ws, is) t (extTA2JVM P ta'') 
        final_thread.actions_ok' (ls, (ts, h), ws, is) t (extTA2JVM P ta'')  final_thread.actions_subset (extTA2JVM P ta'') ta"
        by(auto simp add: final_thread.actions_ok'_convert_extTA elim: final_thread.actions_subset.cases del: subsetI)
      ultimately show ?thesis by blast
    next
      case MEnter
      with exec sees naok ws have False
        by(cases xcp)(auto split: if_split_asm simp add: lock_ok_las'_def finfun_upd_apply ta_upd_simps)
      thus ?thesis ..
    next
      case MExit
      with exec sees False check ws obtain a where [simp]: "hd stk = Addr a" "xcp = None" "ws t = None"
        and ta: "ta = Unlocka, SyncUnlock a  ta = UnlockFaila"
        by(cases xcp)(fastforce split: if_split_asm simp add: lock_ok_las'_def finfun_upd_apply is_Ref_def check_def)+
      from ta show ?thesis
      proof(rule disjE)
        assume ta: "ta = Unlocka, SyncUnlock a"
        let ?ta' = "UnlockFaila"
        from ta exec sees MExit obtain σ'
          where "(?ta', σ')  exec P t (xcp, h, f # Frs)" by auto
        with check have "P,t  Normal (xcp, h, (stk, loc, C, M, pc) # Frs) -?ta'-jvmd→ Normal σ'"
          by -(rule exec_1_d.exec_1_d_NormalI, auto simp add: exec_d_def)
        moreover from False ta have "has_locks (ls $ a) t = 0"
          by(auto simp add: lock_ok_las'_def finfun_upd_apply ta_upd_simps)
        hence "final_thread.actions_ok' (ls, (ts, h), ws, is) t ?ta'"
          by(auto simp add: lock_ok_las'_def finfun_upd_apply ta_upd_simps)
        moreover from ta have "final_thread.actions_subset ?ta' ta"
          by(auto simp add: final_thread.actions_subset_iff collect_locks'_def finfun_upd_apply ta_upd_simps)
        ultimately show ?thesis by(fastforce simp add: ta_upd_simps)
      next
        assume ta: "ta = UnlockFaila"
        let ?ta' = "Unlocka, SyncUnlock a"
        from ta exec sees MExit obtain σ'
          where "(?ta', σ')  exec P t (xcp, h, f # Frs)" by auto
        with check have "P,t  Normal (xcp, h, (stk, loc, C, M, pc) # Frs) -?ta'-jvmd→ Normal σ'"
          by -(rule exec_1_d.exec_1_d_NormalI, auto simp add: exec_d_def)
        moreover from False ta have "has_lock (ls $ a) t"
          by(auto simp add: lock_ok_las'_def finfun_upd_apply ta_upd_simps)
        hence "final_thread.actions_ok' (ls, (ts, h), ws, is) t ?ta'"
          by(auto simp add: lock_ok_las'_def finfun_upd_apply ta_upd_simps)
        moreover from ta have "final_thread.actions_subset ?ta' ta"
          by(auto simp add: final_thread.actions_subset_iff collect_locks'_def finfun_upd_apply ta_upd_simps)
        ultimately show ?thesis by(fastforce simp add: ta_upd_simps)
      qed
    qed(case_tac [!] xcp, auto simp add: split_beta lock_ok_las'_def split: if_split_asm)
  qed
  thus "ta' x' m'. mexecd P t (x, shr s) ta' (x', m')  
                   (final_thread.actions_ok JVM_final s t ta' 
                    final_thread.actions_ok' s t ta'  final_thread.actions_subset ta' ta)"
    by fastforce
next
  fix s t x
  assume wfs: "s  ?wf_state"
    and tst: "thr s t = (x, no_wait_locks)"
    and "¬ JVM_final x"
  from wfs have correct: "correct_state_ts Φ (thr s) (shr s)"
    by(auto dest: execd_mthr.wset_Suspend_okD1 simp add: correct_jvm_state_def)
  obtain xcp frs where x: "x = (xcp, frs)" by (cases x, auto)
  with ¬ JVM_final x obtain f Frs where "frs = f # Frs"
    by(fastforce simp add: neq_Nil_conv)
  with tst correct x have "Φ  t: (xcp, shr s, f # Frs) " by(auto dest: ts_okD)
  with ‹wf_jvm_progΦ P
  have "exec_d P t (xcp, shr s, f # Frs)  TypeError" by(auto dest: no_type_error)
  then obtain Σ where "exec_d P t (xcp, shr s, f # Frs) = Normal Σ" by(auto)
  hence "exec P t (xcp, shr s, f # Frs) = Σ"
    by(auto simp add: exec_d_def check_def split: if_split_asm)
  with progress[OF wf Φ  t: (xcp, shr s, f # Frs) ]
  obtain ta σ where "(ta, σ)  Σ" unfolding exec_1_iff by blast
  with x = (xcp, frs) frs = f # Frs Φ  t: (xcp, shr s, f # Frs) 
    ‹wf_jvm_progΦ P ‹exec_d P t (xcp, shr s, f # Frs) = Normal Σ
  show "ta x' m'. mexecd P t (x, shr s) ta (x', m')"
    by(cases ta, cases σ)(fastforce simp add: split_paired_Ex intro: exec_1_d_NormalI)
qed(fastforce dest: defensive_imp_aggressive_1 mexec_instr_Wakeup_no_Join exec_ta_satisfiable)+

end

context JVM_conf_read begin

lemma mexecT_eq_mexecdT:
  assumes wf: "wf_jvm_progΦ P"
  and cs: "correct_state_ts Φ (thr s) (shr s)"
  shows "P  s -ttajvm s' = P  s -ttajvmd s'"
proof(rule iffI)
  assume "P  s -ttajvm s'"
  thus "P  s -ttajvmd s'"
  proof(cases rule: exec_mthr.redT_elims[consumes 1, case_names normal acquire])
    case (normal x x' m')
    obtain xcp frs where x [simp]: "x = (xcp, frs)" by(cases x, auto)
    from ‹thr s t = (x, no_wait_locks) cs
    have "Φ  t: (xcp, shr s, frs) " by(auto dest: ts_okD)
    from mexec_eq_mexecd[OF wf Φ  t: (xcp, shr s, frs) ] ‹mexec P t (x, shr s) ta (x', m')
    have *: "mexecd P t (x, shr s) ta (x', m')" by simp
    with lifting_wf.redT_updTs_preserves[OF lifting_wf_correct_state_d[OF wf] cs, OF this ‹thr s t = (x, no_wait_locks)] ‹thread_oks (thr s) tat
    have "correct_state_ts Φ (redT_updTs (thr s) tat(t  (x', redT_updLns (locks s) t no_wait_locks tal))) m'" by simp
    with * show ?thesis using normal 
      by(cases s')(erule execd_mthr.redT_normal, auto)
  next
    case acquire thus ?thesis
      apply(cases s', clarify)
      apply(rule execd_mthr.redT_acquire, assumption+)
      by(auto)
  qed
next
  assume "P  s -ttajvmd s'"
  thus "P  s -ttajvm s'"
  proof(cases rule: execd_mthr.redT_elims[consumes 1, case_names normal acquire])
    case (normal x x' m')
    obtain xcp frs where x [simp]: "x = (xcp, frs)" by(cases x, auto)
    from ‹thr s t = (x, no_wait_locks) cs
    have "Φ  t: (xcp, shr s, frs) " by(auto dest: ts_okD)
    from mexec_eq_mexecd[OF wf Φ  t: (xcp, shr s, frs) ] ‹mexecd P t (x, shr s) ta (x', m')
    have "mexec P t (x, shr s) ta (x', m')" by simp
    moreover from lifting_wf.redT_updTs_preserves[OF lifting_wf_correct_state_d[OF wf] cs, OF ‹mexecd P t (x, shr s) ta (x', m') ‹thr s t = (x, no_wait_locks)] ‹thread_oks (thr s) tat
    have "correct_state_ts Φ (redT_updTs (thr s) tat(t  (x', redT_updLns (locks s) t no_wait_locks tal))) m'" by simp
    ultimately show ?thesis using normal
      by(cases s')(erule exec_mthr.redT_normal, auto)
  next
    case acquire thus ?thesis
      apply(cases s', clarify)
      apply(rule exec_mthr.redT_acquire, assumption+)
      by(auto)
  qed
qed

lemma mExecT_eq_mExecdT:
  assumes wf: "wf_jvm_progΦ P"
  and ct: "correct_state_ts Φ (thr s) (shr s)"
  shows "P  s -▹ttasjvm* s' = P  s -▹ttasjvmd* s'"
proof
  assume Red: "P  s -▹ttasjvm* s'"
  thus "P  s -▹ttasjvmd* s'" using ct
  proof(induct rule: exec_mthr.RedT_induct[consumes 1, case_names refl step])
    case refl thus ?case by auto
  next
    case (step s ttas s' t ta s'')
    hence "P  s -▹ttasjvmd* s'" by blast
    moreover from ‹correct_state_ts Φ (thr s) (shr s) P  s -▹ttasjvm* s'
    have "correct_state_ts Φ (thr s') (shr s')"
      by(auto dest: preserves_correct_state[OF wf])
    with P  s' -ttajvm s'' have "P  s' -ttajvmd s''"
      by(unfold mexecT_eq_mexecdT[OF wf])
    ultimately show ?case
      by(blast intro: execd_mthr.RedTI rtrancl3p_step elim: execd_mthr.RedTE)
  qed
next
  assume Red: "P  s -▹ttasjvmd* s'"
  thus "P  s -▹ttasjvm* s'" using ct
  proof(induct rule: execd_mthr.RedT_induct[consumes 1, case_names refl step])
    case refl thus ?case by auto
  next
    case (step s ttas s' t ta s'')
    hence "P  s -▹ttasjvm* s'" by blast
    moreover from ‹correct_state_ts Φ (thr s) (shr s) P  s -▹ttasjvmd* s'
    have "correct_state_ts Φ (thr s') (shr s')"
      by(auto dest: preserves_correct_state_d[OF wf])
    with P  s' -ttajvmd s'' have "P  s' -ttajvm s''"
      by(unfold mexecT_eq_mexecdT[OF wf])
    ultimately show ?case
      by(blast intro: exec_mthr.RedTI rtrancl3p_step elim: exec_mthr.RedTE)
  qed
qed

lemma mexecT_preserves_thread_conf: 
  " wf_jvm_progΦ P; correct_state_ts Φ (thr s) (shr s);
    P  s -t'tajvm s'; thread_conf P (thr s) (shr s)  
   thread_conf P (thr s') (shr s')"
by(simp only: mexecT_eq_mexecdT)(rule execd_tconf.redT_preserves)

lemma mExecT_preserves_thread_conf: 
  " wf_jvm_progΦ P; correct_state_ts Φ (thr s) (shr s);
    P  s -▹ttajvm* s'; thread_conf P (thr s) (shr s) 
   thread_conf P (thr s') (shr s')"
by(simp only: mExecT_eq_mExecdT)(rule execd_tconf.RedT_preserves)

lemma wset_Suspend_ok_mexecd_mexec:
  assumes wf: "wf_jvm_progΦ P"
  shows "exec_mthr.wset_Suspend_ok P (correct_jvm_state Φ) = execd_mthr.wset_Suspend_ok P (correct_jvm_state Φ)"
apply(safe)
 apply(rule execd_mthr.wset_Suspend_okI)
  apply(erule exec_mthr.wset_Suspend_okD1)
 apply(drule (1) exec_mthr.wset_Suspend_okD2)
 apply(subst (asm) (2) split_paired_Ex)
 apply(elim bexE exE conjE)
 apply(subst (asm) mexec_eq_mexecd[OF wf])
  apply(simp add: correct_jvm_state_def)
  apply(blast dest: ts_okD)
 apply(subst (asm) mexecT_eq_mexecdT[OF wf])
  apply(simp add: correct_jvm_state_def)
 apply(subst (asm) mExecT_eq_mExecdT[OF wf])
  apply(simp add: correct_jvm_state_def)
 apply(rule bexI exI|erule conjI|assumption)+
apply(rule exec_mthr.wset_Suspend_okI)
 apply(erule execd_mthr.wset_Suspend_okD1)
apply(drule (1) execd_mthr.wset_Suspend_okD2)
apply(subst (asm) (2) split_paired_Ex)
apply(elim bexE exE conjE)
apply(subst (asm) mexec_eq_mexecd[OF wf, symmetric])
 apply(simp add: correct_jvm_state_def)
 apply(blast dest: ts_okD)
apply(subst (asm) mexecT_eq_mexecdT[OF wf, symmetric])
 apply(simp add: correct_jvm_state_def)
apply(subst (asm) mExecT_eq_mExecdT[OF wf, symmetric])
 apply(simp add: correct_jvm_state_def)
apply(rule bexI exI|erule conjI|assumption)+
done

end

context JVM_typesafe begin

lemma exec_wf_progress:
  assumes wf: "wf_jvm_progΦ P"
  shows "progress JVM_final (mexec P) (exec_mthr.wset_Suspend_ok P (correct_jvm_state Φ))"
  (is "progress _ _ ?wf_state")
proof -
  interpret progress: progress JVM_final "mexecd P" convert_RA ?wf_state
    using assms unfolding wset_Suspend_ok_mexecd_mexec[OF wf] by(rule execd_wf_progress)
  show ?thesis
  proof(unfold_locales)
    fix s
    assume "s  ?wf_state"
    thus "lock_thread_ok (locks s) (thr s)  exec_mthr.wset_final_ok (wset s) (thr s)"
      by(rule progress.wf_stateD)
  next
    fix s t x ta x' m'
    assume wfs: "s  ?wf_state"
      and tst: "thr s t = (x, no_wait_locks)"
      and exec: "mexec P t (x, shr s) ta (x', m')"
      and wait: "¬ waiting (wset s t)"
    from wfs tst have correct: "Φ  t: (fst x, shr s, snd x) "
      by(auto dest!: exec_mthr.wset_Suspend_okD1 ts_okD simp add: correct_jvm_state_def)
    with exec have "mexecd P t (x, shr s) ta (x', m')"
      by(cases x)(simp only: mexec_eq_mexecd[OF wf] fst_conv snd_conv)
    from progress.wf_red[OF wfs tst this wait] correct
    show "ta' x' m'. mexec P t (x, shr s) ta' (x', m')  
                      (final_thread.actions_ok JVM_final s t ta' 
                       final_thread.actions_ok' s t ta'  final_thread.actions_subset ta' ta)"
      by(cases x)(simp only: fst_conv snd_conv mexec_eq_mexecd[OF wf])
  next
    fix s t x ta x' m' w
    assume wfs: "s  ?wf_state"
      and tst: "thr s t = (x, no_wait_locks)" 
      and exec: "mexec P t (x, shr s) ta (x', m')"
      and wait: "¬ waiting (wset s t)"
      and Suspend: "Suspend w  set taw"
    from wfs tst have correct: "Φ  t: (fst x, shr s, snd x) "
      by(auto dest!: exec_mthr.wset_Suspend_okD1 ts_okD simp add: correct_jvm_state_def)
    with exec have "mexecd P t (x, shr s) ta (x', m')"
      by(cases x)(simp only: mexec_eq_mexecd[OF wf] fst_conv snd_conv)
    with wfs tst show "¬ JVM_final x'" using wait Suspend by(rule progress.red_wait_set_not_final)
  next
    fix s t x
    assume wfs: "s  ?wf_state"
      and tst: "thr s t = (x, no_wait_locks)"
      and "¬ JVM_final x"
    from progress.wf_progress[OF this]
    show "ta x' m'. mexec P t (x, shr s) ta (x', m')"
      by(auto dest: defensive_imp_aggressive_1 simp add: split_beta)
  qed(fastforce dest: mexec_instr_Wakeup_no_Join exec_ta_satisfiable)+
qed

theorem mexecd_TypeSafety:
  fixes ln :: "'addr ⇒f nat"
  assumes wf: "wf_jvm_progΦ P"
  and s: "s  execd_mthr.wset_Suspend_ok P (correct_jvm_state Φ)"
  and Exec: "P  s -▹ttasjvmd* s'"
  and "¬ (t ta s''. P  s' -ttajvmd s'')"
  and ts't: "thr s' t = ((xcp, frs), ln)"
  shows "frs  []  ln  no_wait_locks  t  execd_mthr.deadlocked P s'"
  and "Φ  t: (xcp, shr s', frs) "
proof -
  interpret progress JVM_final "mexecd P" convert_RA "execd_mthr.wset_Suspend_ok P (correct_jvm_state Φ)"
    by(rule execd_wf_progress) fact+

  from Exec s have wfs': "s'  execd_mthr.wset_Suspend_ok P (correct_jvm_state Φ)"
    unfolding execd_mthr.RedT_def
    by(blast intro: invariant3p_rtrancl3p execd_mthr.invariant3p_wset_Suspend_ok invariant3p_correct_jvm_state_mexecdT[OF wf])

  with ts't show cst: "Φ  t: (xcp, shr s', frs) "
    by(auto dest: ts_okD execd_mthr.wset_Suspend_okD1 simp add: correct_jvm_state_def)
  assume nfin: "frs  []  ln  no_wait_locks"
  from nfin ‹thr s' t = ((xcp, frs), ln) have "exec_mthr.not_final_thread s' t"
    by(auto simp: exec_mthr.not_final_thread_iff)
  from ¬ (t ta s''. P  s' -ttajvmd s'')
  show "t  execd_mthr.deadlocked P s'"
  proof(rule contrapos_np)
    assume "t  execd_mthr.deadlocked P s'"
    with ‹exec_mthr.not_final_thread s' t have "¬ execd_mthr.deadlocked' P s'"
      by(auto simp add: execd_mthr.deadlocked'_def)
    hence "¬ execd_mthr.deadlock P s'" unfolding execd_mthr.deadlock_eq_deadlocked' .
    thus "t ta s''. P  s' -ttajvmd s''" by(rule redT_progress[OF wfs'])
  qed
qed

theorem mexec_TypeSafety:
  fixes ln :: "'addr ⇒f nat"
  assumes wf: "wf_jvm_progΦ P"
  and s: "s  exec_mthr.wset_Suspend_ok P (correct_jvm_state Φ)"
  and Exec: "P  s -▹ttasjvm* s'"
  and "¬ (t ta s''. P  s' -ttajvm s'')"
  and ts't: "thr s' t = ((xcp, frs), ln)"
  shows "frs  []  ln  no_wait_locks  t  multithreaded_base.deadlocked JVM_final (mexec P) s'"
  and "Φ  t: (xcp, shr s', frs) "
proof -
  interpret progress JVM_final "mexec P" convert_RA "exec_mthr.wset_Suspend_ok P (correct_jvm_state Φ)"
    by(rule exec_wf_progress) fact+

  from Exec s have wfs': "s'  exec_mthr.wset_Suspend_ok P (correct_jvm_state Φ)"
    unfolding exec_mthr.RedT_def
    by(blast intro: invariant3p_rtrancl3p exec_mthr.invariant3p_wset_Suspend_ok invariant3p_correct_jvm_state_mexecT[OF wf])

  with ts't show cst: "Φ  t: (xcp, shr s', frs) "
    by(auto dest: ts_okD exec_mthr.wset_Suspend_okD1 simp add: correct_jvm_state_def)

  assume nfin: "frs  []  ln  no_wait_locks"
  from nfin ‹thr s' t = ((xcp, frs), ln) have "exec_mthr.not_final_thread s' t"
    by(auto simp: exec_mthr.not_final_thread_iff)
  from ¬ (t ta s''. P  s' -ttajvm s'')
  show "t  exec_mthr.deadlocked P s'"
  proof(rule contrapos_np)
    assume "t  exec_mthr.deadlocked P s'"
    with ‹exec_mthr.not_final_thread s' t have "¬ exec_mthr.deadlocked' P s'"
      by(auto simp add: exec_mthr.deadlocked'_def)
    hence "¬ exec_mthr.deadlock P s'" unfolding exec_mthr.deadlock_eq_deadlocked' .
    thus "t ta s''. P  s' -ttajvm s''" by(rule redT_progress[OF wfs'])
  qed
qed

lemma start_mexec_mexecd_commute:
  assumes wf: "wf_jvm_progΦ P"
  and start: "wf_start_state P C M vs"
  shows "P  JVM_start_state P C M vs -▹ttasjvmd* s  P  JVM_start_state P C M vs -▹ttasjvm* s"
using correct_jvm_state_initial[OF assms]
by(clarsimp simp add: correct_jvm_state_def)(rule mExecT_eq_mExecdT[symmetric, OF wf])

theorem mRtrancl_eq_mRtrancld:
  assumes wf: "wf_jvm_progΦ P"
  and ct: "correct_state_ts Φ (thr s) (shr s)"
  shows "exec_mthr.mthr.Rtrancl3p P s ttas  execd_mthr.mthr.Rtrancl3p P s ttas" (is "?lhs  ?rhs")
proof
  show ?lhs if ?rhs using that ct
  proof(coinduction arbitrary: s ttas)
    case Rtrancl3p
    interpret lifting_wf "JVM_final" "mexecd P" convert_RA "λt (xcp, frs) h. Φ  t: (xcp, h, frs) "
      using wf by(rule lifting_wf_correct_state_d)
    from Rtrancl3p(1) show ?case
    proof cases
      case stop: Rtrancl3p_stop
      then show ?thesis using mexecT_eq_mexecdT[OF wf Rtrancl3p(2)] by clarsimp
    next
      case (Rtrancl3p_into_Rtrancl3p s' ttas' tta)
      then show ?thesis using mexecT_eq_mexecdT[OF wf Rtrancl3p(2)] Rtrancl3p(2)
        by(cases tta; cases s')(fastforce simp add: split_paired_Ex dest: redT_preserves)
    qed
  qed
    
  show ?rhs if ?lhs using that ct
  proof(coinduction arbitrary: s ttas)
    case Rtrancl3p
    interpret lifting_wf "JVM_final" "mexec P" convert_RA "λt (xcp, frs) h. Φ  t: (xcp, h, frs) "
      using wf by(rule lifting_wf_correct_state)
    from Rtrancl3p(1) show ?case
    proof cases
      case stop: Rtrancl3p_stop
      then show ?thesis using mexecT_eq_mexecdT[OF wf Rtrancl3p(2)] by clarsimp
    next
      case (Rtrancl3p_into_Rtrancl3p s' ttas' tta)
      then show ?thesis using mexecT_eq_mexecdT[OF wf Rtrancl3p(2)] Rtrancl3p(2)
        by(cases tta; cases s')(fastforce simp add: split_paired_Ex dest: redT_preserves)
    qed
  qed
qed

lemma start_mRtrancl_mRtrancld_commute:
  assumes wf: "wf_jvm_progΦ P"
  and start: "wf_start_state P C M vs"
  shows "exec_mthr.mthr.Rtrancl3p P (JVM_start_state P C M vs) ttas  execd_mthr.mthr.Rtrancl3p P (JVM_start_state P C M vs) ttas"
using correct_jvm_state_initial[OF assms] by(clarsimp simp add: correct_jvm_state_def mRtrancl_eq_mRtrancld[OF wf])
  
end

subsection ‹Determinism›

context JVM_heap_conf begin

lemma exec_instr_deterministic:
  assumes wf: "wf_prog wf_md P"
  and det: "deterministic_heap_ops"
  and exec1: "(ta', σ')  exec_instr i P t (shr s) stk loc C M pc frs"
  and exec2: "(ta'', σ'')  exec_instr i P t (shr s) stk loc C M pc frs"
  and check: "check_instr i P (shr s) stk loc C M pc frs"
  and aok1: "final_thread.actions_ok final s t ta'"
  and aok2: "final_thread.actions_ok final s t ta''"
  and tconf: "P,shr s  t √t"
  shows "ta' = ta''  σ' = σ''"
using exec1 exec2 aok1 aok2
proof(cases i)
  case (Invoke M' n)
  { fix T ta''' ta'''' va' va'' h' h''
    assume T: "typeof_addr (shr s) (the_Addr (stk ! n)) = T"
      and "method": "snd (snd (snd (method P (class_type_of T) M'))) = None" "P  class_type_of T has M'"
      and params: "P,shr s  rev (take n stk) [:≤] fst (snd (method P (class_type_of T) M'))"
      and red1: "(ta''', va', h')  red_external_aggr P t (the_Addr (stk ! n)) M' (rev (take n stk)) (shr s)"
      and red2: "(ta'''', va'', h'')  red_external_aggr P t (the_Addr (stk ! n)) M' (rev (take n stk)) (shr s)"
      and ta': "ta' = extTA2JVM P ta'''"
      and ta'': "ta'' = extTA2JVM P ta''''"
    from T "method" params obtain T' where "P,shr s  the_Addr (stk ! n)M'(rev (take n stk)) : T'"
      by(fastforce simp add: has_method_def confs_conv_map external_WT'_iff)
    hence "P,t  the_Addr (stk ! n)M'(rev (take n stk)), shr s -ta'''→ext va', h'"
      and "P,t  the_Addr (stk ! n)M'(rev (take n stk)), shr s -ta''''→ext va'', h''"
      using red1 red2 tconf
      by-(rule WT_red_external_aggr_imp_red_external[OF wf], assumption+)+
    moreover from aok1 aok2 ta' ta''
    have "final_thread.actions_ok final s t ta'''"
      and "final_thread.actions_ok final s t ta''''"
      by(auto simp add: final_thread.actions_ok_iff)
    ultimately have "ta''' = ta''''  va' = va''  h' = h''"
      by(rule red_external_deterministic[OF det]) }
  with assms Invoke show ?thesis
    by(clarsimp simp add: split_beta split: if_split_asm) blast
next
  case MExit
  { assume "final_thread.actions_ok final s t UnlockFailthe_Addr (hd stk)"
    and "final_thread.actions_ok final s t Unlockthe_Addr (hd stk), SyncUnlock (the_Addr (hd stk))"
    hence False 
      by(auto simp add: final_thread.actions_ok_iff lock_ok_las_def finfun_upd_apply elim!: allE[where x="the_Addr (hd stk)"]) }
  with assms MExit show ?thesis by(auto split: if_split_asm)
qed(auto simp add: split_beta split: if_split_asm dest: deterministic_heap_ops_readD[OF det] deterministic_heap_ops_writeD[OF det] deterministic_heap_ops_allocateD[OF det])

lemma exec_1_deterministic:
  assumes wf: "wf_jvm_progΦ P"
  and det: "deterministic_heap_ops"
  and exec1: "P,t  (xcp, shr s, frs) -ta'-jvm→ σ'"
  and exec2: "P,t  (xcp, shr s, frs) -ta''-jvm→ σ''"
  and aok1: "final_thread.actions_ok final s t ta'"
  and aok2: "final_thread.actions_ok final s t ta''"
  and conf: "Φ  t:(xcp, shr s, frs) "
  shows "ta' = ta''  σ' = σ''"
proof -
  from wf obtain wf_md where wf': "wf_prog wf_md P" by(blast dest: wt_jvm_progD)
  from conf have tconf: "P,shr s  t √t" by(simp add: correct_state_def)
  from exec1 conf have "P,t  Normal (xcp, shr s, frs) -ta'-jvmd→ Normal σ'"
    by(simp add: welltyped_commute[OF wf])
  hence "check P (xcp, shr s, frs)" by(rule jvmd_NormalE)
  with exec1 exec2 aok1 aok2 tconf show ?thesis
    by(cases xcp)(case_tac [!] frs, auto elim!: exec_1.cases dest: exec_instr_deterministic[OF wf' det] simp add: check_def split_beta)
qed

end

context JVM_conf_read begin

lemma invariant3p_correct_state_ts:
  assumes "wf_jvm_progΦ P"
  shows "invariant3p (mexecT P) {s. correct_state_ts Φ (thr s) (shr s)}"
using assms by(rule lifting_wf.invariant3p_ts_ok[OF lifting_wf_correct_state])

lemma mexec_deterministic:
  assumes wf: "wf_jvm_progΦ P"
  and det: "deterministic_heap_ops"
  shows "exec_mthr.deterministic P {s. correct_state_ts Φ (thr s) (shr s)}"
proof(rule exec_mthr.determisticI)
  fix s t x ta' x' m' ta'' x'' m''
  assume tst: "thr s t = (x, no_wait_locks)"
    and red: "mexec P t (x, shr s) ta' (x', m')" "mexec P t (x, shr s) ta'' (x'', m'')"
    and aok: "exec_mthr.actions_ok s t ta'" "exec_mthr.actions_ok s t ta''"
    and correct [simplified]: "s  {s. correct_state_ts Φ (thr s) (shr s)}"
  moreover obtain xcp frs where [simp]: "x = (xcp, frs)" by(cases x)
  moreover obtain xcp' frs' where [simp]: "x' = (xcp', frs')" by(cases x')
  moreover obtain xcp'' frs'' where [simp]: "x'' = (xcp'', frs'')" by(cases x'')
  ultimately have exec1: "P,t  (xcp, shr s, frs) -ta'-jvm→ (xcp', m', frs')"
    and exec1: "P,t  (xcp, shr s, frs) -ta''-jvm→ (xcp'', m'', frs'')"
    by simp_all
  moreover note aok
  moreover from correct tst have "Φ  t:(xcp, shr s, frs)"
    by(auto dest: ts_okD)
  ultimately have "ta' = ta''  (xcp', m', frs') = (xcp'', m'', frs'')"
    by(rule exec_1_deterministic[OF wf det])
  thus "ta' = ta''  x' = x''  m' = m''" by simp
qed(rule invariant3p_correct_state_ts[OF wf])

end

end

Theory JVMDeadlocked

(*  Title:      JinjaThreads/BV/JVMDeadlocked.thy
    Author:     Andreas Lochbihler
*)

section ‹Preservation of deadlock for the JVMs›

theory JVMDeadlocked
imports
  BVProgressThreaded
begin

context JVM_progress begin

lemma must_sync_preserved_d:
  assumes wf: "wf_jvm_progΦ P"
  and ml: "execd_mthr.must_sync P t (xcp, frs) h" 
  and hext: "hext h h'"
  and hconf': "hconf h'"
  and cs: "Φ  t: (xcp, h, frs) "
  shows "execd_mthr.must_sync P t (xcp, frs) h'"
proof(rule execd_mthr.must_syncI)
  from ml obtain ta xcp' frs' m'
    where red: "P,t  Normal (xcp, h, frs) -ta-jvmd→ Normal (xcp', m', frs')"
    by(auto elim: execd_mthr.must_syncE)
  then obtain f Frs
    where check: "check P (xcp, h, frs)"
    and exec: "(ta, xcp', m', frs')  exec P t (xcp, h, frs)"
    and [simp]: "frs = f # Frs"
    by(auto elim: jvmd_NormalE)
  from cs hext hconf' have cs': "Φ  t: (xcp, h', frs) "
    by(rule correct_state_hext_mono)
  then obtain ta σ' where exec: "P,t  (xcp, h', frs) -ta-jvm→ σ'"
    by(auto dest: progress[OF wf])
  hence "P,t  Normal (xcp, h', frs) -ta-jvmd→ Normal σ'"
    unfolding welltyped_commute[OF wf cs'] .
  moreover from exec have "s. exec_mthr.actions_ok s t ta" by(rule exec_ta_satisfiable)
  ultimately show "ta x' m' s. mexecd P t ((xcp, frs), h') ta (x', m')  exec_mthr.actions_ok s t ta"
    by(cases σ')(fastforce simp del: split_paired_Ex)
qed

lemma can_sync_devreserp_d:
  assumes wf: "wf_jvm_progΦ P"
  and cl': "execd_mthr.can_sync P t (xcp, frs) h' L" 
  and cs: "Φ  t: (xcp, h, frs) "
  and hext: "hext h h'"
  and hconf': "hconf h'"
  shows "L'L. execd_mthr.can_sync P t (xcp, frs) h L'"
proof -
  from cl' obtain ta xcp' frs' m'
    where red: "P,t  Normal (xcp, h', frs) -ta-jvmd→ Normal (xcp', m', frs')"
    and L: "L = collect_locks tal <+> collect_cond_actions tac <+> collect_interrupts tai"
    by -(erule execd_mthr.can_syncE, auto)
  then obtain f Frs
    where check: "check P (xcp, h', frs)"
    and exec: "(ta, xcp', m', frs')  exec P t (xcp, h', frs)"
    and [simp]: "frs = f # Frs"
    by(auto elim: jvmd_NormalE simp add: finfun_upd_apply)
  obtain stk loc C M pc where [simp]: "f = (stk, loc, C, M, pc)" by (cases f, blast)
  from cs obtain ST LT Ts T mxs mxl ins xt where
    hconf:  "hconf h" and
    tconf:  "P,h  t √t" and
    meth:   "P  C sees M:TsT = (mxs, mxl, ins, xt) in C" and
    Φ:      "Φ C M ! pc = Some (ST,LT)" and
    frame:  "conf_f P h (ST,LT) ins (stk,loc,C,M,pc)" and
    frames: "conf_fs P h Φ M (size Ts) T Frs" 
    by (fastforce simp add: correct_state_def dest: sees_method_fun)
  from cs have "exec P t (xcp, h, f # Frs)  {}"
    by(auto dest!: progress[OF wf] simp add: exec_1_iff)
  with no_type_error[OF wf cs] have check': "check P (xcp, h, frs)"
    by(auto simp add: exec_d_def split: if_split_asm)
  from wf obtain wfmd where wfp: "wf_prog wfmd P" by(auto dest: wt_jvm_progD)
  from tconf hext have tconf': "P,h'  t √t" by(rule tconf_hext_mono)
  show ?thesis
  proof(cases xcp)
    case [simp]: (Some a)
    with exec have [simp]: "m' = h'" by(auto)
    from Φ  t: (xcp, h, frs)  obtain D where D: "typeof_addr h a = Class_type D"
      by(auto simp add: correct_state_def)
    with hext have "cname_of h a = cname_of h' a" by(auto dest: hext_objD simp add: cname_of_def)
    with exec have "(ta, xcp', h, frs')  exec P t (xcp, h, frs)" by auto
    moreover from check D hext have "check P (xcp, h, frs)"
      by(auto simp add: check_def check_xcpt_def dest: hext_objD)
    ultimately have "P,t  Normal (xcp, h, frs) -ta-jvmd→ Normal (xcp', h, frs')"
      by -(rule exec_1_d_NormalI, simp only: exec_d_def if_True)
    with L have "execd_mthr.can_sync P t (xcp, frs) h L"
      by(auto intro: execd_mthr.can_syncI)
    thus ?thesis by auto
  next
    case [simp]: None

    note [simp] = defs1 list_all2_Cons2

    from frame have ST: "P,h  stk [:≤] ST"
      and LT: "P,h  loc [:≤] LT"
      and pc: "pc < length ins" by simp_all
    from wf meth pc have wt: "P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M"
      by(rule wt_jvm_prog_impl_wt_instr)

    from Φ  t: (xcp, h, frs) 
    have "ta σ'. P,t  (xcp, h, f # Frs) -ta-jvm→ σ'"
      by(auto dest: progress[OF wf] simp del: correct_state_def split_paired_Ex)
    with exec meth have "ta' σ'. (ta', σ')  exec P t (xcp, h, frs)  collect_locks ta'l  collect_locks tal  collect_cond_actions ta'c  collect_cond_actions tac  collect_interrupts ta'i  collect_interrupts tai"
    proof(cases "ins ! pc")
      case (Invoke M' n)
      show ?thesis
      proof(cases "stk ! n = Null")
        case True with Invoke exec meth show ?thesis by simp
      next
        case False
        with check meth obtain a where a: "stk ! n = Addr a" and n: "n < length stk"
          by(auto simp add: check_def is_Ref_def Invoke)
        from frame have stk: "P,h  stk [:≤] ST" by(auto simp add: conf_f_def)
        hence "P,h  stk ! n :≤ ST ! n" using n by(rule list_all2_nthD)
        with a obtain ao Ta where Ta: "typeof_addr h a = Ta"
          by(auto simp add: conf_def)
        from hext Ta have Ta': "typeof_addr h' a = Ta" by(rule typeof_addr_hext_mono)
        with check a meth Invoke False obtain D Ts' T' meth D'
          where C: "D = class_type_of Ta"
          and sees': "P  D sees M':Ts'T' = meth in D'"
          and params: "P,h'  rev (take n stk) [:≤] Ts'"
          by(auto simp add: check_def has_method_def)
        show ?thesis
        proof(cases "meth")
          case Some
          with exec meth a Ta Ta' Invoke n sees' C show ?thesis by(simp add: split_beta)
        next
          case None
          with exec meth a Ta Ta' Invoke n sees' C
          obtain ta' va h'' where ta': "ta = extTA2JVM P ta'"
            and va: "(xcp', m', frs') = extRet2JVM n h'' stk loc C M pc Frs va"
            and exec': "(ta', va, h'')  red_external_aggr P t a M' (rev (take n stk)) h'"
            by(fastforce)
          from va have [simp]: "h'' = m'" by(cases va) simp_all
          note Ta moreover from None sees' wfp have "D'M'(Ts') :: T'" by(auto intro: sees_wf_native)
          with C sees' params Ta' None have "P,h'  aM'(rev (take n stk)) : T'"
            by(auto simp add: external_WT'_iff confs_conv_map)
          with wfp exec' tconf' have red: "P,t  aM'(rev (take n stk)), h' -ta'→ext va, m'"
            by(simp add: WT_red_external_list_conv)

          from stk have "P,h  take n stk [:≤] take n ST" by(rule list_all2_takeI)
          then obtain Ts where "map typeofh (take n stk) = map Some Ts"
            by(auto simp add: confs_conv_map)
          hence "map typeofh (rev (take n stk)) = map Some (rev Ts)" by(simp only: rev_map[symmetric])
          moreover hence "map typeofh' (rev (take n stk)) = map Some (rev Ts)" using hext by(rule map_typeof_hext_mono)
          with P,h'  aM'(rev (take n stk)) : T' D'M'(Ts') :: T' sees' C Ta' Ta
          have "P  rev Ts [≤] Ts'" by cases (auto dest: sees_method_fun)
          ultimately have "P,h  aM'(rev (take n stk)) : T'"
            using Ta C sees' params None D'M'(Ts') :: T'
            by(auto simp add: external_WT'_iff confs_conv_map)
          from red_external_wt_hconf_hext[OF wfp red hext this tconf hconf]
          obtain ta'' va' h''' where "P,t  aM'(rev (take n stk)),h -ta''→ext va',h'''"
            and ta'': "collect_locks ta''l = collect_locks ta'l" 
            "collect_cond_actions ta''c = collect_cond_actions ta'c"
            "collect_interrupts ta''i = collect_interrupts ta'i"
            by auto
          with None a Ta Invoke meth Ta' n C sees'
          have "(extTA2JVM P ta'', extRet2JVM n h''' stk loc C M pc Frs va')  exec P t (xcp, h, frs)"
            by(force intro: red_external_imp_red_external_aggr simp del: split_paired_Ex)
          with ta'' ta' show ?thesis by(fastforce simp del: split_paired_Ex)
        qed
      qed
    qed(auto 4 4 split: if_split_asm simp add: split_beta ta_upd_simps exec_1_iff intro: rev_image_eqI simp del: split_paired_Ex)
    with check' have "ta' σ'. P,t  Normal (xcp, h, frs) -ta'-jvmd→ Normal σ'  collect_locks ta'l  collect_locks tal 
      collect_cond_actions ta'c  collect_cond_actions tac  collect_interrupts ta'i  collect_interrupts tai"
      apply clarify
      apply(rule exI conjI)+
      apply(rule exec_1_d.exec_1_d_NormalI, auto simp add: exec_d_def)
      done
    with L show ?thesis
      apply -
      apply(erule exE conjE|rule exI conjI)+
      prefer 2
      apply(rule_tac x'="(fst σ', snd (snd σ'))" and m'="fst (snd σ')" in execd_mthr.can_syncI)
      apply auto
      done
  qed
qed

end

context JVM_typesafe begin

lemma execd_preserve_deadlocked:
  assumes wf: "wf_jvm_progΦ P"
  shows "preserve_deadlocked JVM_final (mexecd P) convert_RA (correct_jvm_state Φ)"
proof(unfold_locales)
  show "invariant3p (mexecdT P) (correct_jvm_state Φ)"
    by(rule invariant3p_correct_jvm_state_mexecdT[OF wf])
next
  fix s t' ta' s' t x ln
  assume s: "s  correct_jvm_state Φ"
    and red: "P  s -t'ta'jvmd s'"
    and tst: "thr s t = (x, ln)"
    and "execd_mthr.must_sync P t x (shr s)"
  moreover obtain xcp frs where x [simp]: "x = (xcp, frs)" by(cases x, auto)
  ultimately have ml: "execd_mthr.must_sync P t (xcp, frs) (shr s)" by simp
  moreover from s have cs': "correct_state_ts Φ (thr s) (shr s)" by(simp add: correct_jvm_state_def)
  with tst have "Φ  t: (xcp, shr s, frs) " by(auto dest: ts_okD)
  moreover from red have "hext (shr s) (shr s')" by(rule execd_hext)
  moreover from wf red cs' have "correct_state_ts Φ (thr s') (shr s')"
    by(rule lifting_wf.redT_preserves[OF lifting_wf_correct_state_d])
  from red tst have "thr s' t  None"
    by(cases s)(cases s', rule notI, auto dest: execd_mthr.redT_thread_not_disappear)
  with ‹correct_state_ts Φ (thr s') (shr s') have "hconf (shr s')"
    by(auto dest: ts_okD simp add: correct_state_def)
  ultimately have "execd_mthr.must_sync P t (xcp, frs) (shr s')"
    by-(rule must_sync_preserved_d[OF wf])
  thus "execd_mthr.must_sync P t x (shr s')" by simp
next
  fix s t' ta' s' t x ln L
  assume s: "s  correct_jvm_state Φ"
    and red: "P  s -t'ta'jvmd s'"
    and tst: "thr s t = (x, ln)"
    and "execd_mthr.can_sync P t x (shr s') L"
  moreover obtain xcp frs where x [simp]: "x = (xcp, frs)" by(cases x, auto)
  ultimately have ml: "execd_mthr.can_sync P t (xcp, frs) (shr s') L" by simp
  moreover from s have cs': "correct_state_ts Φ (thr s) (shr s)" by(simp add: correct_jvm_state_def)
  with tst have "Φ  t: (xcp, shr s, frs) " by(auto dest: ts_okD)
  moreover from red have "hext (shr s) (shr s')" by(rule execd_hext)
  moreover from red tst have "thr s' t  None"
    by(cases s)(cases s', rule notI, auto dest: execd_mthr.redT_thread_not_disappear)
  from red cs' have "correct_state_ts Φ (thr s') (shr s')"
    by(rule lifting_wf.redT_preserves[OF lifting_wf_correct_state_d[OF wf]])
  with ‹thr s' t  None› have "hconf (shr s')"
    by(auto dest: ts_okD simp add: correct_state_def)
  ultimately have "L'  L. execd_mthr.can_sync P t (xcp, frs) (shr s) L'"
    by-(rule can_sync_devreserp_d[OF wf])
  thus "L'  L. execd_mthr.can_sync P t x (shr s) L'" by simp
qed

end


text ‹and now everything again for the aggresive VM›

context JVM_heap_conf_base' begin

lemma must_lock_d_eq_must_lock:
  " wf_jvm_progΦ P; Φ  t: (xcp, h, frs)  
   execd_mthr.must_sync P t (xcp, frs) h = exec_mthr.must_sync P t (xcp, frs) h"
apply(rule iffI)
 apply(rule exec_mthr.must_syncI)
 apply(erule execd_mthr.must_syncE)
 apply(simp only: mexec_eq_mexecd)
 apply(blast)
apply(rule execd_mthr.must_syncI)
apply(erule exec_mthr.must_syncE)
apply(simp only: mexec_eq_mexecd[symmetric])
apply(blast)
done

lemma can_lock_d_eq_can_lock:
  " wf_jvm_progΦ P; Φ  t: (xcp, h, frs)  
   execd_mthr.can_sync P t (xcp, frs) h L = exec_mthr.can_sync P t (xcp, frs) h L"
apply(rule iffI)
 apply(erule execd_mthr.can_syncE)
 apply(rule exec_mthr.can_syncI)
   apply(simp only: mexec_eq_mexecd)
  apply(assumption)+
apply(erule exec_mthr.can_syncE)
apply(rule execd_mthr.can_syncI)
 by(simp only: mexec_eq_mexecd)

end

context JVM_typesafe begin

lemma exec_preserve_deadlocked:
  assumes wf: "wf_jvm_progΦ P"
  shows "preserve_deadlocked JVM_final (mexec P) convert_RA (correct_jvm_state Φ)"
proof -
  interpret preserve_deadlocked JVM_final "mexecd P" convert_RA "correct_jvm_state Φ"
    by(rule execd_preserve_deadlocked) fact+

  { fix s t' ta' s' t x
    assume s: "s  correct_jvm_state Φ"
      and red: "P  s -t'ta'jvm s'"
      and tst: "thr s t = (x, no_wait_locks)"
    obtain xcp frs where x [simp]: "x = (xcp, frs)" by(cases x, auto)
    from s have css: "correct_state_ts Φ (thr s) (shr s)" by(simp add: correct_jvm_state_def)
    with red have redd: "P  s -t'ta'jvmd s'" by(simp add: mexecT_eq_mexecdT[OF wf])
    from css tst have cst: "Φ  t: (xcp, shr s, frs) " by(auto dest: ts_okD)
    from redd have cst': "Φ  t: (xcp, shr s', frs) "
    proof(cases rule: execd_mthr.redT_elims)
      case acquire with cst show ?thesis by simp
    next
      case (normal X X' M' ws')
      obtain XCP FRS where X [simp]: "X = (XCP, FRS)" by(cases X, auto)
      obtain XCP' FRS' where X' [simp]: "X' = (XCP', FRS')" by(cases X', auto)
      from ‹mexecd P t' (X, shr s) ta' (X', M')
      have "P,t'  Normal (XCP, shr s, FRS) -ta'-jvmd→ Normal (XCP', M', FRS')" by simp
      moreover from ‹thr s t' = (X, no_wait_locks) css
      have "Φ  t': (XCP, shr s, FRS) " by(auto dest: ts_okD)
      ultimately have "Φ  t': (XCP, M', FRS) " by -(rule correct_state_heap_change[OF wf])
      moreover from lifting_wf.redT_updTs_preserves[OF lifting_wf_correct_state_d[OF wf] css, OF ‹mexecd P t' (X, shr s) ta' (X', M') ‹thr s t' = (X, no_wait_locks), of no_wait_locks] ‹thread_oks (thr s) ta't
      have "correct_state_ts Φ (redT_updTs (thr s) ta't(t'  (X', no_wait_locks))) M'" by simp
      ultimately have "correct_state_ts Φ (redT_updTs (thr s) ta't) M'"
        using ‹thr s t' = (X, no_wait_locks) ‹thread_oks (thr s) ta't
        apply(auto intro!: ts_okI dest: ts_okD)
        apply(case_tac "t=t'")
         apply(fastforce dest: redT_updTs_Some)
        apply(drule_tac t=t in ts_okD, fastforce+)
        done
      hence "correct_state_ts Φ (redT_updTs (thr s) ta't) (shr s')" 
        using s' = (redT_updLs (locks s) t' ta'l, (redT_updTs (thr s) ta't(t'  (X', redT_updLns (locks s) t' no_wait_locks ta'l)), M'), ws', redT_updIs (interrupts s) ta'i)
        by simp
      moreover from tst ‹thread_oks (thr s) ta't
      have "redT_updTs (thr s) ta't t = (x, no_wait_locks)" by(auto intro: redT_updTs_Some)
      ultimately show ?thesis by(auto dest: ts_okD)
    qed
    { assume "exec_mthr.must_sync P t x (shr s)"
      hence ml: "exec_mthr.must_sync P t (xcp, frs) (shr s)" by simp
      with cst have "execd_mthr.must_sync P t (xcp, frs) (shr s)"
        by(auto dest: must_lock_d_eq_must_lock[OF wf])
      with s redd tst have "execd_mthr.must_sync P t x (shr s')"
        unfolding x by(rule can_lock_preserved)
      with cst' have "exec_mthr.must_sync P t x (shr s')"
        by(auto dest: must_lock_d_eq_must_lock[OF wf]) }
    note ml = this
    { fix L
      assume "exec_mthr.can_sync P t x (shr s') L"
      hence cl: "exec_mthr.can_sync P t (xcp, frs) (shr s') L" by simp
      with cst' have "execd_mthr.can_sync P t (xcp, frs) (shr s') L"
        by(auto dest: can_lock_d_eq_can_lock[OF wf])
      with s redd tst
      have "L'  L. execd_mthr.can_sync P t x (shr s) L'"
        unfolding x by(rule can_lock_devreserp)
      then obtain L' where "execd_mthr.can_sync P t x (shr s) L'" 
        and L': "L' L" by blast
      with cst have "exec_mthr.can_sync P t x (shr s) L'"
        by(auto dest: can_lock_d_eq_can_lock[OF wf])
      with L' have "L'  L. exec_mthr.can_sync P t x (shr s) L'"
        by(blast) }
    note this ml }
  moreover have "invariant3p (mexecT P) (correct_jvm_state Φ)" by(rule invariant3p_correct_jvm_state_mexecT[OF wf])
  ultimately show ?thesis by(unfold_locales)
qed

end

end

Theory EffectMono

(*  Title:      JinjaThreads/BV/EffectMono.thy
    Author:     Gerwin Klein, Andreas Lochbihler
*)

section ‹Monotonicity of eff and app›

theory EffectMono
imports
  Effect
begin

declare not_Err_eq [iff]

declare widens_trans[trans]

lemma appi_mono: 
  assumes wf: "wf_prog p P"
  assumes less: "P  τ i τ'"
  shows "appi (i,P,mxs,mpc,rT,τ')  appi (i,P,mxs,mpc,rT,τ)"
proof -
  assume app: "appi (i,P,mxs,mpc,rT,τ')"
  
  obtain ST LT ST' LT' where
    [simp]: "τ = (ST,LT)" and
    [simp]: "τ' = (ST',LT')" 
    by (cases τ, cases τ')

  from less have [simp]: "size ST = size ST'" and [simp]: "size LT = size LT'"
    by (auto dest: list_all2_lengthD)

  note [iff] = list_all2_Cons2 widen_Class  
  note [simp] = fun_of_def 

  from app less show "appi (i,P,mxs,mpc,rT,τ)"
  proof (cases i)
    case Load
    with app less show ?thesis by (auto dest!: list_all2_nthD)
  next
    case (Invoke M n)
    with app have n: "n < size ST'" by simp
    
    { assume "ST!n = NT" hence ?thesis using n app Invoke by simp }
    moreover {
      assume "ST'!n = NT"
      moreover with n less have "ST!n = NT" 
        by (auto dest: list_all2_nthD)
      ultimately have ?thesis using n app Invoke by simp }
    moreover {
      assume ST: "ST!n  NT" and ST': "ST'!n  NT" 

      from ST' app Invoke
      obtain D Ts T m C'
        where D: "class_type_of' (ST' ! n) = D"
        and Ts: "P  rev (take n ST') [≤] Ts"
        and D_M: "P  D sees M: TsT = m in C'"
        by fastforce

      from less have "P  ST!n  ST'!n"
        by(auto dest: list_all2_nthD2[OF _ n])
      with D obtain D' where D': "class_type_of' (ST ! n) = D'" 
        and DsubC: "P  D' * D"
        using ST by(rule widen_is_class_type_of)
      from wf D_M DsubC obtain Ts' T' m' C'' where
        D'_M: "P  D' sees M: Ts'T' = m' in C''" and
        Ts': "P  Ts [≤] Ts'"
        by (blast dest: sees_method_mono)
      from less have "P  rev (take n ST) [≤] rev (take n ST')" by simp
      also note Ts also note Ts' 
      finally have "P  rev (take n ST) [≤] Ts'" .
      with D'_M D' app less Invoke D have ?thesis by(auto)
    }
    ultimately show ?thesis by blast
  next 
    case Getfield
    with app less show ?thesis
      by(fastforce simp add: sees_field_def widen_Array dest: has_fields_fun)
  next
    case Putfield
    with app less show ?thesis
      by (fastforce intro: widen_trans rtrancl_trans simp add: sees_field_def widen_Array dest: has_fields_fun)
  next
    case CAS
    with app less show ?thesis
      by (fastforce intro: widen_trans rtrancl_trans simp add: sees_field_def widen_Array dest: has_fields_fun)
  next
    case Return
    with app less show ?thesis by (fastforce intro: widen_trans)
  next
    case ALoad
    with app less show ?thesis by(auto simp add: widen_Array)
  next
    case AStore
    with app less show ?thesis by(auto simp add: widen_Array)
  next
    case ALength
    with app less show ?thesis by(auto simp add: widen_Array)
  next
    case (Checkcast T)
    with app less show ?thesis
      by(auto elim!: refTE simp: widen_Array)
  next
    case (Instanceof T)
    with app less show ?thesis
      by(auto elim!: refTE simp: widen_Array)
  next
    case ThrowExc
    with app less show ?thesis
      by(auto elim!: refTE simp: widen_Array)
  next
    case MEnter
    with app less show ?thesis
      by(auto elim!: refTE simp: widen_Array)
  next
    case MExit
    with app less show ?thesis
      by(auto elim!: refTE simp: widen_Array)
  next
    case (BinOpInstr bop)
    with app less show ?thesis by(force dest: WTrt_binop_widen_mono)
  next
    case Dup
    with app less show ?thesis
      by(auto dest: list_all2_lengthD)
  next
    case Swap
    with app less show ?thesis
      by(auto dest: list_all2_lengthD)
  qed (auto elim!: refTE not_refTE)
qed

lemma succs_mono:
  assumes wf: "wf_prog p P" and appi: "appi (i,P,mxs,mpc,rT,τ')"
  shows "P  τ i τ'  set (succs i τ pc)  set (succs i τ' pc)"
proof (cases i)
  case (Invoke M n)
  obtain ST LT ST' LT' where 
    [simp]: "τ = (ST,LT)" and [simp]: "τ' = (ST',LT')" by (cases τ, cases τ') 
  assume "P  τ i τ'"
  moreover
  with appi Invoke have "n < size ST" by (auto dest: list_all2_lengthD)
  ultimately
  have "P  ST!n  ST'!n" by (auto simp add: fun_of_def dest: list_all2_nthD)
  with Invoke show ?thesis by auto 
next
  case ALoad
  obtain ST LT ST' LT' where 
    [simp]: "τ = (ST,LT)" and [simp]: "τ' = (ST',LT')" by (cases τ, cases τ') 
  assume "P  τ i τ'"
  moreover
  with appi ALoad have "1 < size ST" by (auto dest: list_all2_lengthD)
  ultimately
  have "P  ST!1  ST'!1" by (auto simp add: fun_of_def dest: list_all2_nthD)
  with ALoad show ?thesis by auto
next 
  case AStore
  obtain ST LT ST' LT' where 
    [simp]: "τ = (ST,LT)" and [simp]: "τ' = (ST',LT')" by (cases τ, cases τ') 
  assume "P  τ i τ'"
  moreover
  with appi AStore have "2 < size ST" by (auto dest: list_all2_lengthD)
  ultimately
  have "P  ST!2  ST'!2" by (auto simp add: fun_of_def dest: list_all2_nthD)
  with AStore show ?thesis by auto
next
  case ALength
  obtain ST LT ST' LT' where 
    [simp]: "τ = (ST,LT)" and [simp]: "τ' = (ST',LT')" by (cases τ, cases τ') 
  assume "P  τ i τ'"
  moreover
  with appi ALength have "0 < size ST" by (auto dest: list_all2_lengthD)
  ultimately
  have "P  ST!0  ST'!0" by (auto simp add: fun_of_def dest: list_all2_nthD)
  with ALength show ?thesis by auto
next
  case MEnter
  obtain ST LT ST' LT' where 
    [simp]: "τ = (ST,LT)" and [simp]: "τ' = (ST',LT')" by (cases τ, cases τ') 
  assume "P  τ i τ'"
  moreover
  with appi MEnter have "0 < size ST" by (auto dest: list_all2_lengthD)
  ultimately
  have "P  ST!0  ST'!0" by (auto simp add: fun_of_def dest: list_all2_nthD)
  with MEnter show ?thesis by auto
next
  case MExit
  obtain ST LT ST' LT' where 
    [simp]: "τ = (ST,LT)" and [simp]: "τ' = (ST',LT')" by (cases τ, cases τ') 
  assume "P  τ i τ'"
  moreover
  with appi MExit have "0 < size ST" by (auto dest: list_all2_lengthD)
  ultimately
  have "P  ST!0  ST'!0" by (auto simp add: fun_of_def dest: list_all2_nthD)
  with MExit show ?thesis by auto
qed auto

lemma app_mono: 
  assumes wf: "wf_prog p P"
  assumes less': "P  τ ≤' τ'"
  shows "app i P m rT pc mpc xt τ'  app i P m rT pc mpc xt τ"
proof (cases τ)
  case None thus ?thesis by simp
next
  case (Some τ1) 
  moreover
  with less' obtain τ2 where τ2: "τ' = Some τ2" by (cases τ') auto
  ultimately have less: "P  τ1 i τ2" using less' by simp
  
  assume "app i P m rT pc mpc xt τ'"
  with Some τ2 obtain
    appi: "appi (i, P, pc, m, rT, τ2)" and
    xcpt: "xcpt_app i P pc m xt τ2" and
    succs: "(pc',s')set (eff i P pc xt (Some τ2)). pc' < mpc"
    by (auto simp add: app_def)
  
  from wf less appi have "appi (i, P, pc, m, rT, τ1)" by (rule appi_mono)
  moreover
  from less have "size (fst τ1) = size (fst τ2)" 
    by (cases τ1, cases τ2) (auto dest: list_all2_lengthD)
  with xcpt have "xcpt_app i P pc m xt τ1" by (simp add: xcpt_app_def)
  moreover
  from wf appi less have "pc. set (succs i τ1 pc)  set (succs i τ2 pc)"
    by (blast dest: succs_mono)
  with succs
  have "(pc',s')set (eff i P pc xt (Some τ1)). pc' < mpc"
    by (cases τ1, cases τ2)
       (auto simp add: eff_def norm_eff_def xcpt_eff_def dest: bspec)
  ultimately
  show ?thesis using Some by (simp add: app_def)
qed

lemma effi_mono:
  assumes wf: "wf_prog p P"
  assumes less: "P  τ i τ'"
  assumes appi: "app i P m rT pc mpc xt (Some τ')"
  assumes succs: "succs i τ pc  []"  "succs i τ' pc  []"
  shows "P  effi (i,P,τ) i effi (i,P,τ')"
proof -
  obtain ST LT ST' LT' where
    [simp]: "τ = (ST,LT)" and
    [simp]: "τ' = (ST',LT')" 
    by (cases τ, cases τ')
  
  note [simp] = eff_def app_def fun_of_def 

  from less have "P  (Some τ) ≤' (Some τ')" by simp
  from wf this appi 
  have app: "app i P m rT pc mpc xt (Some τ)" by (rule app_mono)

  from less app appi show ?thesis
  proof (cases i)
    case ThrowExc with succs have False by simp
    thus ?thesis ..
  next
    case Return with succs have False by simp
    thus ?thesis ..
  next
    case (Load i)
    from Load app obtain y where
       y:  "i < size LT" "LT!i = OK y" by clarsimp
    from Load appi obtain y' where
       y': "i < size LT'" "LT'!i = OK y'" by clarsimp

    from less have "P  LT [≤] LT'" by simp
    with y y' have "P  y  y'" by (auto dest: list_all2_nthD)    
    with Load less y y' app appi
    show ?thesis by auto
  next
    case Store with less app appi
    show ?thesis by (auto simp add: list_all2_update_cong) 
  next
    case (Invoke M n) 
    with appi have n: "n < size ST'" by simp
    from less have [simp]: "size ST = size ST'" 
      by (auto dest: list_all2_lengthD)

    from Invoke succs have ST: "ST!n  NT" and ST': "ST'!n  NT" by (auto)
    
    from ST' appi Invoke obtain D Ts T m C'
      where D: "class_type_of' (ST' ! n) = D"
      and Ts: "P  rev (take n ST') [≤] Ts"
      and D_M: "P  D sees M: TsT = m in C'"
      by fastforce

    from less have "P  ST!n  ST'!n" by(auto dest: list_all2_nthD2[OF _ n])
    with D obtain D' where D': "class_type_of' (ST ! n) = D'" 
      and DsubC: "P  D' * D"
      using ST by(rule widen_is_class_type_of)

    from wf D_M DsubC obtain Ts' T' m' C'' where
      D'_M: "P  D' sees M: Ts'T' = m' in C''" and
      Ts': "P  Ts [≤] Ts'" and "P  T'  T" by (blast dest: sees_method_mono)

    show ?thesis using Invoke n D D' D_M less D'_M Ts' P  T'  T
      by(auto intro: list_all2_dropI)
  next
    case ALoad with less app appi succs
    show ?thesis by(auto split: if_split_asm dest: Array_Array_widen)
  next
    case AStore with less app appi succs
    show ?thesis by(auto split: if_split_asm dest: Array_Array_widen)
  next
    case (BinOpInstr bop)
    with less app appi succs show ?thesis
      by auto(force dest: WTrt_binop_widen_mono WTrt_binop_fun)
  qed auto
qed

end

Theory TF_JVM

(*  Title:      JinjaThreads/BV/TF_JVM.thy
    Author:     Tobias Nipkow, Gerwin Klein, Andreas Lochbihler
*)

section ‹The Typing Framework for the JVM \label{sec:JVM}›

theory TF_JVM
imports
  "../DFA/Typing_Framework_err" 
  EffectMono 
  BVSpec
  "../Common/ExternalCallWF"
begin

definition exec :: "'addr jvm_prog  nat  ty  ex_table  'addr instr list  tyi' err step_type"
where
  "exec G maxs rT et bs 
   err_step (size bs) (λpc. app (bs!pc) G maxs rT pc (size bs) et) (λpc. eff (bs!pc) G pc et)"

locale JVM_sl =
  fixes P :: "'addr jvm_prog" and mxs and mxl0
  fixes Ts :: "ty list" and "is" :: "'addr instr list" and xt and Tr

  fixes mxl and A and r and f and app and eff and step
  defines [simp]: "mxl  1+size Ts+mxl0"
  defines [simp]: "A    states P mxs mxl"
  defines [simp]: "r    JVM_SemiType.le P mxs mxl"
  defines [simp]: "f    JVM_SemiType.sup P mxs mxl"

  defines [simp]: "app  λpc. Effect.app (is!pc) P mxs Tr pc (size is) xt"
  defines [simp]: "eff  λpc. Effect.eff (is!pc) P pc xt"
  defines [simp]: "step  err_step (size is) app eff"


locale start_context = JVM_sl +
  fixes p and C
  assumes wf: "wf_prog p P"
  assumes C:  "is_class P C"
  assumes Ts: "set Ts  types P"

  fixes first :: tyi' and start
  defines [simp]: 
  "first  Some ([],OK (Class C) # map OK Ts @ replicate mxl0 Err)"
  defines [simp]:
  "start  OK first # replicate (size is - 1) (OK None)"


subsection ‹Connecting JVM and Framework›

lemma (in JVM_sl) step_def_exec: "step  exec P mxs Tr xt is" 
  by (simp add: exec_def)  

lemma special_ex_swap_lemma [iff]: 
  "(X. (n. X = A n  P n)  Q X) = (n. Q(A n)  P n)"
  by blast

lemma ex_in_list [iff]:
  "(n. ST  list n A  n  mxs) = (set ST  A  size ST  mxs)"
  by (unfold list_def) auto

lemma singleton_list: 
  "(n. [Class C]  list n (types P)  n  mxs) = (is_class P C  0 < mxs)"
  by(auto)

lemma set_drop_subset:
  "set xs  A  set (drop n xs)  A"
  by (auto dest: in_set_dropD)

lemma Suc_minus_minus_le:
  "n < mxs  Suc (n - (n - b))  mxs"
  by arith

lemma in_listE:
  " xs  list n A; size xs = n; set xs  A  P   P"
  by (unfold list_def) blast

declare is_relevant_entry_def [simp]
declare set_drop_subset [simp]

lemma (in start_context) [simp, intro!]: "is_class P Throwable"
apply(rule converse_subcls_is_class[OF wf])
 apply(rule xcpt_subcls_Throwable[OF _ wf])
 prefer 2
 apply(rule is_class_xcpt[OF _ wf])
apply(fastforce simp add: sys_xcpts_def sys_xcpts_list_def)+
done

declare option.splits[split del]
declare option.case_cong[cong]
declare is_type_array [simp del]

theorem (in start_context) exec_pres_type:
  "pres_type step (size is) A"
(*<*)
  apply (insert wf)
  apply simp
  apply (unfold JVM_states_unfold)
  apply (rule pres_type_lift)
  apply clarify
  apply (rename_tac s pc pc' s')
  apply (case_tac s)
   apply simp
   apply (drule effNone)
   apply simp  
  apply (simp add: Effect.app_def xcpt_app_def Effect.eff_def  
                   xcpt_eff_def norm_eff_def relevant_entries_def)
  apply (case_tac "is!pc")

  subgoal ― ‹Load›
    apply(clarsimp split: option.splits)
    apply (frule listE_nth_in, assumption)
    apply(fastforce split: option.splits)
    done

  subgoal ― ‹Store›
    apply clarsimp
    apply(erule disjE)
     apply clarsimp
    apply(fastforce split: option.splits)
    done

  subgoal ― ‹Push›
    by(fastforce simp add: typeof_lit_is_type split: option.splits)

  subgoal ― ‹New›
    apply (clarsimp)
    apply (erule disjE)
     apply clarsimp
    apply (clarsimp)
    apply(rule conjI)
     apply(force split: option.splits)
    apply fastforce
    done

  subgoal ― ‹NewArray›
    apply clarsimp
    apply (erule disjE)
     apply clarsimp
    apply (clarsimp)
    apply (erule allE)+
    apply(erule impE, blast)
    apply(force split: option.splits)
    done

  subgoal ― ‹ALoad›
    apply(clarsimp split: if_split_asm)
     apply(rule conjI)
      apply(fastforce split: option.splits)
     apply(erule allE)+
     apply(erule impE, blast)
     apply arith
    apply(erule disjE)
     apply(fastforce dest: is_type_ArrayD)
    apply(clarsimp)
    apply(rule conjI)
     apply(fastforce split: option.splits)
    apply(erule allE)+
    apply(erule impE, blast)
    apply arith
    done

  subgoal ― ‹AStore›
    apply(clarsimp split: if_split_asm)
     apply(rule conjI)
      apply(fastforce split: option.splits)
     apply(erule allE)+
     apply(erule impE, blast)
     apply arith
    apply(erule disjE)
     apply(fastforce)
    apply clarsimp
    apply(rule conjI)
     apply(fastforce split: option.splits)
    apply(erule allE)+
    apply(erule impE, blast)
    apply arith
    done

  subgoal ― ‹ALength›
    apply(clarsimp split: if_split_asm)
     apply(rule conjI)
      apply(fastforce split: option.splits)
     apply(erule allE)+
     apply(erule impE, blast)
     apply arith
    apply(erule disjE)
     apply(fastforce)
    apply clarsimp
    apply(rule conjI)
     apply(fastforce split: option.splits)
    apply(erule allE)+
    apply(erule impE, blast)
    apply arith
    done

  subgoal ― ‹Getfield›
    apply(clarsimp)
    apply(erule disjE)
     apply(fastforce dest: sees_field_is_type)
    apply clarsimp
    apply(rule conjI)
     apply(fastforce split: option.splits)
    apply fastforce
    done

  subgoal ― ‹Putfield›
    apply(clarsimp)
    apply(erule disjE)
     apply(fastforce)
    apply clarsimp
    apply(rule conjI)
     apply(fastforce split: option.splits)
    apply fastforce
    done

  subgoal ― ‹CAS›
    apply clarsimp
    apply(erule disjE)
     apply fastforce
    apply clarsimp
    apply(rule conjI)
     apply(fastforce split: option.splits)
    apply fastforce
    done

  subgoal ― ‹Checkcast›
    apply(clarsimp)
    apply(erule disjE)
     apply(fastforce)
    apply clarsimp
    apply(rule conjI)
     apply(fastforce split: option.splits)
    apply fastforce
    done

  subgoal ― ‹Instanceof›
    apply(clarsimp)
    apply(erule disjE)
     apply(fastforce)
    apply clarsimp
    apply(rule conjI)
     apply(fastforce split: option.splits)
    apply fastforce
    done

  subgoal for … the_s M n
    apply (clarsimp split: if_split_asm)
     apply(rule conjI)
      apply(fastforce split!: option.splits)
     apply fastforce
    apply(erule disjE)
     apply clarsimp
     apply(rule conjI)
      apply(drule (1) sees_wf_mdecl)
      apply(clarsimp simp add: wf_mdecl_def)
     apply(arith)
    apply(clarsimp)
    apply(erule allE)+
    apply(rotate_tac -2)
    apply(erule impE, blast)
    apply(clarsimp split: option.splits)
    done
  
  subgoal ― ‹Return›
    by(fastforce split: option.splits)

  subgoal ― ‹Pop›
    apply(clarsimp)
    apply(erule disjE)
     apply(fastforce)
    apply clarsimp
    apply(rule conjI)
     apply(fastforce split: option.splits)
    apply fastforce
    done

  subgoal ― ‹Dup›
    apply(clarsimp)
    apply(erule disjE)
     apply(fastforce)
    apply clarsimp
    apply(rule conjI)
     apply(fastforce split: option.splits)
    apply fastforce
    done

  subgoal ― ‹Swap›
    apply(clarsimp)
    apply(erule disjE)
     apply(fastforce)
    apply clarsimp
    apply(rule conjI)
     apply(fastforce split: option.splits)
    apply fastforce
    done

  subgoal ― ‹BinOpInstr›
    apply(clarsimp)
    apply(erule disjE)
     apply(fastforce intro: WTrt_binop_is_type)
    apply clarsimp
    apply(rule conjI)
     apply(fastforce split: option.splits)
    apply fastforce
    done
  
  subgoal ― ‹Goto›
    by(fastforce split: option.splits)

  subgoal ― ‹IfFalse›
    apply(clarsimp)
    apply(erule disjE)
     apply(fastforce)
    apply(erule disjE)
     apply fastforce
    apply clarsimp
    apply(rule conjI)
     apply(fastforce split: option.splits)
    apply fastforce
    done

  subgoal ― ‹ThrowExc›
    apply(clarsimp)
    apply(rule conjI)
     apply(erule allE)+
     apply(erule impE, blast)
     apply(clarsimp split: option.splits)
    apply fastforce
    done

  subgoal ― ‹MEnter›
    apply(clarsimp)
    apply(erule disjE)
     apply(fastforce)
    apply clarsimp
    apply(rule conjI)
     apply(fastforce split: option.splits)
    apply fastforce
    done

  subgoal ― ‹MExit›
    apply(clarsimp)
    apply(erule disjE)
     apply(fastforce)
    apply clarsimp
    apply(rule conjI)
     apply(fastforce split: option.splits)
    apply fastforce
    done
  done
(*>*)

declare option.case_cong_weak[cong]
declare option.splits[split]
declare is_type_array[simp]

declare is_relevant_entry_def [simp del]
declare set_drop_subset [simp del]

lemma lesubstep_type_simple:
  "xs [⊑Product.le (=) r] ys  set xs {⊑r} set ys"
(*<*)
  apply (unfold lesubstep_type_def)
  apply clarify
  apply (simp add: set_conv_nth)
  apply clarify
  apply (drule le_listD, assumption)
  apply (clarsimp simp add: lesub_def Product.le_def)
  apply (rule exI)
  apply (rule conjI)
   apply (rule exI)
   apply (rule conjI)
    apply (rule sym)
    apply assumption
   apply assumption
  apply assumption
  done
(*>*)

declare is_relevant_entry_def [simp del]


lemma conjI2: " A; A  B   A  B" by blast
  
lemma (in JVM_sl) eff_mono:
  "wf_prog p P; pc < length is; ssup_state_opt P t; app pc t
   set (eff pc s) {⊑sup_state_opt P} set (eff pc t)"
(*<*)
  apply simp
  apply (unfold Effect.eff_def)  
  apply (cases t)
   apply (simp add: lesub_def)
  apply (rename_tac a)
  apply (cases s)
   apply simp
  apply (rename_tac b)
  apply simp
  apply (rule lesubstep_union)
   prefer 2
   apply (rule lesubstep_type_simple)
   apply (simp add: xcpt_eff_def)
   apply (rule le_listI)
    apply (simp add: split_beta)
   apply (simp add: split_beta)
   apply (simp add: lesub_def fun_of_def)
   apply (case_tac a)
   apply (case_tac b)
   apply simp   
   apply (subgoal_tac "size ab = size aa")
     prefer 2
     apply (clarsimp simp add: list_all2_lengthD)
   apply simp
  apply (clarsimp simp add: norm_eff_def lesubstep_type_def lesub_def iff del: sup_state_conv)
  apply (rule exI)
  apply (rule conjI2)
   apply (rule imageI)
   apply (clarsimp simp add: Effect.app_def iff del: sup_state_conv)
   apply (drule (2) succs_mono)
   apply blast
  apply simp
  apply (erule effi_mono)
     apply simp
    apply assumption   
   apply clarsimp
  apply clarsimp  
  done
(*>*)

lemma (in JVM_sl) bounded_step: "bounded step (size is)"
(*<*)
  apply simp
  apply (unfold bounded_def err_step_def Effect.app_def Effect.eff_def)
  apply (auto simp add: error_def map_snd_def split: err.splits option.splits)
  done
(*>*)

theorem (in JVM_sl) step_mono:
  "wf_prog wf_mb P  mono r step (size is) A"
(*<*)
  apply (simp add: JVM_le_Err_conv)  
  apply (insert bounded_step)
  apply (unfold JVM_states_unfold)
  apply (rule mono_lift)
     apply blast
    apply (unfold app_mono_def lesub_def)
    apply clarsimp
    apply (erule (2) app_mono)
   apply simp
  apply clarify
  apply (drule eff_mono)
  apply (auto simp add: lesub_def)
  done
(*>*)


lemma (in start_context) first_in_A [iff]: "OK first  A"
  using Ts C by (force intro!: list_appendI simp add: JVM_states_unfold)


lemma (in JVM_sl) wt_method_def2:
  "wt_method P C' Ts Tr mxs mxl0 is xt τs =
  (is  []  
   size τs = size is 
   OK ` set τs  states P mxs mxl 
   wt_start P C' Ts mxl0 τs  
   wt_app_eff (sup_state_opt P) app eff τs)"
(*<*)
  apply (unfold wt_method_def wt_app_eff_def wt_instr_def lesub_def check_types_def)
  apply auto
  done
(*>*)


end

Theory LBVJVM

(*  Title:      HOL/MicroJava/BV/JVM.thy
    Author:     Tobias Nipkow, Gerwin Klein
    Copyright   2000 TUM
*)

section ‹LBV for the JVM \label{sec:JVM}›

theory LBVJVM
imports
  "../DFA/Abstract_BV"
  TF_JVM
begin

type_synonym prog_cert = "cname  mname  tyi' err list"

definition check_cert :: "'addr jvm_prog  nat  nat  nat  tyi' err list  bool"
where
  "check_cert P mxs mxl n cert  check_types P mxs mxl cert  size cert = n+1 
                                 (i<n. cert!i  Err)  cert!n = OK None"

definition lbvjvm :: "'addr jvm_prog  nat  nat  ty  ex_table  
             tyi' err list  'addr instr list  tyi' err  tyi' err"
where
  "lbvjvm P mxs maxr Tr et cert bs 
  wtl_inst_list bs cert (JVM_SemiType.sup P mxs maxr) (JVM_SemiType.le P mxs maxr) Err (OK None) (exec P mxs Tr et bs) 0"

definition wt_lbv :: "'addr jvm_prog  cname  ty list  ty  nat  nat  
             ex_table  tyi' err list  'addr instr list  bool"
where
  "wt_lbv P C Ts Tr mxs mxl0 et cert ins 
   check_cert P mxs (1+size Ts+mxl0) (size ins) cert 
   0 < size ins  
   (let start  = Some ([],(OK (Class C))#((map OK Ts))@(replicate mxl0 Err));
        result = lbvjvm P mxs (1+size Ts+mxl0) Tr et cert ins (OK start)
    in result  Err)"

definition wt_jvm_prog_lbv :: "'addr jvm_prog  prog_cert  bool"
where
  "wt_jvm_prog_lbv P cert 
  wf_prog (λP C (mn,Ts,Tr,(mxs,mxl0,b,et)). wt_lbv P C Ts Tr mxs mxl0 et (cert C mn) b) P"

definition mk_cert :: "'addr jvm_prog  nat  ty  ex_table  'addr instr list 
               tym  tyi' err list"
where
  "mk_cert P mxs Tr et bs phi  make_cert (exec P mxs Tr et bs) (map OK phi) (OK None)"

definition prg_cert :: "'addr jvm_prog  tyP  prog_cert"
where
  "prg_cert P phi C mn  let (C,Ts,Tr,meth) = method P C mn; (mxs,mxl0,ins,et) = the meth
                         in  mk_cert P mxs Tr et ins (phi C mn)"
   
lemma check_certD [intro?]:
  "check_cert P mxs mxl n cert  cert_ok cert n Err (OK None) (states P mxs mxl)"
  by (unfold cert_ok_def check_cert_def check_types_def) auto


lemma (in start_context) wt_lbv_wt_step:
  assumes lbv: "wt_lbv P C Ts Tr mxs mxl0 xt cert is"
  shows "τs  list (size is) A. wt_step r Err step τs  OK first ⊑⇩r τs!0"
(*<*)
proof -
  from wf have "semilat (JVM_SemiType.sl P mxs mxl)" ..
  hence "semilat (A, r, f)" by (simp add: sl_def2)
  moreover have "top r Err" by (simp add: JVM_le_Err_conv)
  moreover have "Err  A" by (simp add: JVM_states_unfold)
  moreover have "bottom r (OK None)" 
    by (simp add: JVM_le_Err_conv bottom_def lesub_def Err.le_def split: err.split)
  moreover have "OK None  A" by (simp add: JVM_states_unfold)
  moreover note bounded_step
  moreover from lbv have "cert_ok cert (size is) Err (OK None) A"
    by (unfold wt_lbv_def) (auto dest: check_certD)
  moreover note exec_pres_type
  moreover
  from lbv 
  have "wtl_inst_list is cert f r Err (OK None) step 0 (OK first)  Err"
    by (simp add: wt_lbv_def lbvjvm_def step_def_exec [symmetric])    
  moreover note first_in_A
  moreover from lbv have "0 < size is" by (simp add: wt_lbv_def)
  ultimately show ?thesis by (rule lbvs.wtl_sound_strong [OF lbvs.intro, OF lbv.intro lbvs_axioms.intro, OF Semilat.intro lbv_axioms.intro])
qed
(*>*)


lemma (in start_context) wt_lbv_wt_method:
  assumes lbv: "wt_lbv P C Ts Tr mxs mxl0 xt cert is"  
  shows "τs. wt_method P C Ts Tr mxs mxl0 is xt τs"
(*<*)
proof -
  from lbv have l: "is  []" by (simp add: wt_lbv_def)
  moreover
  from wf lbv C Ts obtain τs where 
    list:  "τs  list (size is) A" and
    step:  "wt_step r Err step τs" and    
    start: "OK first ⊑⇩r τs!0" 
    by (blast dest: wt_lbv_wt_step)
  from list have [simp]: "size τs = size is" by simp
  have "size (map ok_val τs) = size is" by simp  
  moreover from l have 0: "0 < size τs" by simp
  with step obtain τs0 where "τs!0 = OK τs0"
    by (unfold wt_step_def) blast
  with start 0 have "wt_start P C Ts mxl0 (map ok_val τs)"
    by (simp add: wt_start_def JVM_le_Err_conv lesub_def Err.le_def)    
  moreover {
    from list have "check_types P mxs mxl τs" by (simp add: check_types_def)
    also from step  have "x  set τs. x  Err" 
      by (auto simp add: all_set_conv_all_nth wt_step_def)    
    hence [symmetric]: "map OK (map ok_val τs) = τs"
      by (auto intro!: map_idI)
    finally have "check_types P mxs mxl (map OK (map ok_val τs))" .
  }
  moreover {  
    note bounded_step
    moreover from list have "set τs  A" by simp
    moreover from step have "wt_err_step (sup_state_opt P) step τs"
      by (simp add: wt_err_step_def JVM_le_Err_conv)
    ultimately have "wt_app_eff (sup_state_opt P) app eff (map ok_val τs)"
      by (auto intro: wt_err_imp_wt_app_eff simp add: exec_def states_def)
  }    
  ultimately have "wt_method P C Ts Tr mxs mxl0 is xt (map ok_val τs)"
    by (simp add: wt_method_def2 check_types_def del: map_map)
  thus ?thesis ..
qed
(*>*)

  
lemma (in start_context) wt_method_wt_lbv:
  assumes wt: "wt_method P C Ts Tr mxs mxl0 is xt τs" 
  defines [simp]: "cert  mk_cert P mxs Tr xt is τs"
  
  shows "wt_lbv P C Ts Tr mxs mxl0 xt cert is" 
(*<*)
proof -
  let ?τs  = "map OK τs"
  let ?cert = "make_cert step ?τs (OK None)"

  from wt obtain 
    0:        "0 < size is" and
    size:     "size is = size ?τs" and
    ck_types: "check_types P mxs mxl ?τs" and
    wt_start: "wt_start P C Ts mxl0 τs" and
    app_eff:  "wt_app_eff (sup_state_opt P) app eff τs"
    by (force simp add: wt_method_def2 check_types_def) 
  
  from wf have "semilat (JVM_SemiType.sl P mxs mxl)" ..
  hence "semilat (A, r, f)" by (simp add: sl_def2)
  moreover have "top r Err" by (simp add: JVM_le_Err_conv)
  moreover have "Err  A" by (simp add: JVM_states_unfold)
  moreover have "bottom r (OK None)" 
    by (simp add: JVM_le_Err_conv bottom_def lesub_def Err.le_def split: err.split)
  moreover have "OK None  A" by (simp add: JVM_states_unfold)
  moreover from wf have "mono r step (size is) A" by (rule step_mono)
  hence "mono r step (size ?τs) A" by (simp add: size)
  moreover from exec_pres_type 
  have "pres_type step (size ?τs) A" by (simp add: size) 
  moreover
  from ck_types have τs_in_A: "set ?τs  A" by (simp add: check_types_def)
  hence "pc. pc < size ?τs  ?τs!pc  A  ?τs!pc  Err" by auto
  moreover from bounded_step 
  have "bounded step (size ?τs)" by (simp add: size)
  moreover have "OK None  Err" by simp
  moreover from bounded_step size τs_in_A app_eff
  have "wt_err_step (sup_state_opt P) step ?τs"
    by (auto intro: wt_app_eff_imp_wt_err simp add: exec_def states_def)    
  hence "wt_step r Err step ?τs"
    by (simp add: wt_err_step_def JVM_le_Err_conv)
  moreover
  from 0 size have "0 < size τs" by auto
  hence "?τs!0 = OK (τs!0)" by simp
  with wt_start have "OK first ⊑⇩r ?τs!0"
    by (clarsimp simp add: wt_start_def lesub_def Err.le_def JVM_le_Err_conv)
  moreover note first_in_A
  moreover have "OK first  Err" by simp
  moreover note size 
  ultimately
  have "wtl_inst_list is ?cert f r Err (OK None) step 0 (OK first)  Err"
    by (rule lbvc.wtl_complete [OF lbvc.intro, OF lbv.intro lbvc_axioms.intro, OF Semilat.intro lbv_axioms.intro])
  moreover from 0 size have "τs  []" by auto
  moreover from ck_types have "check_types P mxs mxl ?cert"
    by (auto simp add: make_cert_def check_types_def JVM_states_unfold cong del: image_cong_simp)
  moreover note 0 size
  ultimately show ?thesis 
    by (simp add: wt_lbv_def lbvjvm_def mk_cert_def step_def_exec [symmetric]
                  check_cert_def make_cert_def nth_append)
qed  
(*>*)


theorem jvm_lbv_correct:
  "wt_jvm_prog_lbv P Cert  wf_jvm_prog P"
(*<*)
proof -  
  let  = "λC mn. let (C,Ts,Tr,meth) = method P C mn; (mxs,mxl0,is,xt) = the meth in 
              SOME τs. wt_method P C Ts Tr mxs mxl0 is xt τs"
    
  assume wt: "wt_jvm_prog_lbv P Cert"
  hence "wf_jvm_prog P"
    apply (unfold wf_jvm_prog_phi_def wt_jvm_prog_lbv_def) 
    apply (erule wf_prog_lift)
    apply(auto intro: someI_ex[OF start_context.wt_lbv_wt_method [OF start_context.intro]])
    done
  thus ?thesis by (unfold wf_jvm_prog_def) blast
qed
(*>*)

theorem jvm_lbv_complete:
  assumes wt: "wf_jvm_progΦ P" 
  shows "wt_jvm_prog_lbv P (prg_cert P Φ)"
(*<*)
  using wt
  apply (unfold wf_jvm_prog_phi_def wt_jvm_prog_lbv_def)
  apply (erule wf_prog_lift)
  apply (auto simp add: prg_cert_def 
              intro!: start_context.wt_method_wt_lbv start_context.intro)
  done
(*>*)

end  

Theory BVExec

(*  Title:      HOL/MicroJava/BV/JVM.thy
    Author:     Tobias Nipkow, Gerwin Klein
    Copyright   2000 TUM
*)

section ‹Kildall for the JVM \label{sec:JVM}›

theory BVExec
imports
  "../DFA/Abstract_BV"
  TF_JVM
begin

definition kiljvm :: "'addr jvm_prog  nat  nat  ty  
                    'addr instr list  ex_table  tyi' err list  tyi' err list"
where
  "kiljvm P mxs mxl Tr is xt 
  kildall (JVM_SemiType.le P mxs mxl) (JVM_SemiType.sup P mxs mxl) 
          (exec P mxs Tr xt is)"

definition  wt_kildall :: "'addr jvm_prog  cname  ty list  ty  nat  nat  
                         'addr instr list  ex_table  bool"
where
  "wt_kildall P C' Ts Tr mxs mxl0 is xt 
   0 < size is  
   (let first  = Some ([],[OK (Class C')]@(map OK Ts)@(replicate mxl0 Err));
        start  = OK first#(replicate (size is - 1) (OK None));
        result = kiljvm P mxs (1+size Ts+mxl0) Tr is xt  start
    in n < size is. result!n  Err)"

definition wf_jvm_progk :: "'addr jvm_prog  bool"
where
  "wf_jvm_progk P 
  wf_prog (λP C' (M,Ts,Tr,(mxs,mxl0,is,xt)). wt_kildall P C' Ts Tr mxs mxl0 is xt) P"


theorem (in start_context) is_bcv_kiljvm:
  "is_bcv r Err step (size is) A (kiljvm P mxs mxl Tr is xt)"
(*<*)
  apply (insert wf)
  apply (unfold kiljvm_def)
  apply (fold r_def f_def step_def_exec)
  apply (rule is_bcv_kildall)
       apply simp
       apply (rule Semilat.intro)
       apply (fold sl_def2, erule semilat_JVM)
      apply simp
      apply blast
     apply (simp add: JVM_le_unfold)
    apply (rule exec_pres_type)
   apply (rule bounded_step)
  apply (erule step_mono)
  done
(*>*)

(* FIXME: move? *)
lemma subset_replicate [intro?]: "set (replicate n x)  {x}"
  by (induct n) auto

lemma in_set_replicate:
  assumes "x  set (replicate n y)"
  shows "x = y"
(*<*)
proof -
  note assms
  also have "set (replicate n y)  {y}" ..
  finally show ?thesis by simp
qed
(*>*)

lemma (in start_context) start_in_A [intro?]:
  "0 < size is  start  list (size is) A"
  using Ts C
(*<*)
  apply (simp add: JVM_states_unfold) 
  apply (force intro!: listI list_appendI dest!: in_set_replicate)
  done   
(*>*)


theorem (in start_context) wt_kil_correct:
  assumes wtk: "wt_kildall P C Ts Tr mxs mxl0 is xt"
  shows "τs. wt_method P C Ts Tr mxs mxl0 is xt τs"
(*<*)
proof -
  from wtk obtain res where    
    result:   "res = kiljvm P mxs mxl Tr is xt start" and
    success:  "n < size is. res!n  Err" and
    instrs:   "0 < size is" 
    by (unfold wt_kildall_def) simp
      
  have bcv: "is_bcv r Err step (size is) A (kiljvm P mxs mxl Tr is xt)"
    by (rule is_bcv_kiljvm)
    
  from instrs have "start  list (size is) A" ..
  with bcv success result have 
    "tslist (size is) A. start [⊑⇩r] ts  wt_step r Err step ts"
    by (unfold is_bcv_def) blast
  then obtain τs' where
    in_A: "τs'  list (size is) A" and
    s:    "start [⊑⇩r] τs'" and
    w:    "wt_step r Err step τs'"
    by blast
  hence wt_err_step: "wt_err_step (sup_state_opt P) step τs'"
    by (simp add: wt_err_step_def JVM_le_Err_conv)

  from in_A have l: "size τs' = size is" by simp  
  moreover {
    from in_A  have "check_types P mxs mxl τs'" by (simp add: check_types_def)
    also from w have "x  set τs'. x  Err" 
      by (auto simp add: wt_step_def all_set_conv_all_nth)
    hence [symmetric]: "map OK (map ok_val τs') = τs'" 
      by (auto intro!: map_idI simp add: wt_step_def)
    finally  have "check_types P mxs mxl (map OK (map ok_val τs'))" .
  } 
  moreover {  
    from s have "start!0 ⊑⇩r τs'!0" by (rule le_listD) simp
    moreover
    from instrs w l 
    have "τs'!0  Err" by (unfold wt_step_def) simp
    then obtain τs0 where "τs'!0 = OK τs0" by auto
    ultimately
    have "wt_start P C Ts mxl0 (map ok_val τs')" using l instrs
      by (unfold wt_start_def) 
         (simp add: lesub_def JVM_le_Err_conv Err.le_def)
  }
  moreover 
  from in_A have "set τs'  A" by simp  
  with wt_err_step bounded_step
  have "wt_app_eff (sup_state_opt P) app eff (map ok_val τs')"
    by (auto intro: wt_err_imp_wt_app_eff simp add: l)
  ultimately
  have "wt_method P C Ts Tr mxs mxl0 is xt (map ok_val τs')"
    using instrs by (simp add: wt_method_def2 check_types_def del: map_map)
  thus ?thesis by blast
qed
(*>*)


theorem (in start_context) wt_kil_complete:
  assumes wtm: "wt_method P C Ts Tr mxs mxl0 is xt τs"
  shows "wt_kildall P C Ts Tr mxs mxl0 is xt"
(*<*)
proof -
  from wtm obtain
    instrs:   "0 < size is" and
    length:   "length τs = length is" and 
    ck_type:  "check_types P mxs mxl (map OK τs)" and
    wt_start: "wt_start P C Ts mxl0 τs" and
    app_eff:  "wt_app_eff (sup_state_opt P) app eff τs"
    by (simp add: wt_method_def2 check_types_def)

  from ck_type
  have in_A: "set (map OK τs)  A" 
    by (simp add: check_types_def)  
  with app_eff in_A bounded_step
  have "wt_err_step (sup_state_opt P) (err_step (size τs) app eff) (map OK τs)"
    by - (erule wt_app_eff_imp_wt_err,
          auto simp add: exec_def length states_def)
  hence wt_err: "wt_err_step (sup_state_opt P) step (map OK τs)" 
    by (simp add: length)
  have is_bcv: "is_bcv r Err step (size is) A (kiljvm P mxs mxl Tr is xt)"
    by (rule is_bcv_kiljvm)
  moreover from instrs have "start  list (size is) A" ..
  moreover
  let ?τs = "map OK τs"  
  have less_τs: "start [⊑⇩r] ?τs"
  proof (rule le_listI)
    from length instrs
    show "length start = length (map OK τs)" by simp
  next
    fix n
    from wt_start have "P  ok_val (start!0) ≤' τs!0" 
      by (simp add: wt_start_def)
    moreover from instrs length have "0 < length τs" by simp
    ultimately have "start!0 ⊑⇩r ?τs!0" 
      by (simp add: JVM_le_Err_conv lesub_def)
    moreover {
      fix n'
      have "OK None ⊑⇩r ?τs!n"
        by (auto simp add: JVM_le_Err_conv Err.le_def lesub_def 
                 split: err.splits)
      hence "n = Suc n'; n < size start  start!n ⊑⇩r ?τs!n" by simp
    }
    ultimately
    show "n < size start  start!n ⊑⇩r ?τs!n" by (cases n, blast+)   
  qed
  moreover
  from ck_type length
  have "?τs  list (size is) A"
    by (auto intro!: listI simp add: check_types_def)
  moreover
  from wt_err have "wt_step r Err step ?τs" 
    by (simp add: wt_err_step_def JVM_le_Err_conv)
  ultimately
  have "p. p < size is  kiljvm P  mxs mxl Tr is xt start ! p  Err" 
    by (unfold is_bcv_def) blast
  with instrs 
  show "wt_kildall P C Ts Tr mxs mxl0 is xt" by (unfold wt_kildall_def) simp
qed
(*>*)


theorem jvm_kildall_correct:
  "wf_jvm_progk P = wf_jvm_prog P"
(*<*)
proof 
  let  = "λC M. let (C,Ts,Tr,meth) = method P C M; (mxs,mxl0,is,xt) = the meth in 
              SOME τs. wt_method P C Ts Tr mxs mxl0 is xt τs"

  ― ‹soundness›
  assume wt: "wf_jvm_progk P"
  hence "wf_jvm_prog P"
    apply (unfold wf_jvm_prog_phi_def wf_jvm_progk_def)
    apply (erule wf_prog_lift)
    apply (auto intro: someI_ex[OF start_context.wt_kil_correct [OF start_context.intro]])
    done
  thus "wf_jvm_prog P" by (unfold wf_jvm_prog_def) fast
next
  ― ‹completeness›
  assume wt: "wf_jvm_prog P"
  thus "wf_jvm_progk P"
    apply (unfold wf_jvm_prog_def wf_jvm_prog_phi_def wf_jvm_progk_def)
    apply (clarify)
    apply (erule wf_prog_lift)
    apply (auto intro!: start_context.wt_kil_complete start_context.intro)
    done
qed
(*>*)

end

Theory BCVExec

(*  Title:      JinjaThreads/BV/BCVExec.thy
    Author:     Andreas Lochbihler
*)

section ‹Code generation for the byte code verifier›

theory BCVExec
imports
  BVNoTypeError
  BVExec
begin

lemmas [code_unfold] = exec_lub_def

lemmas [code] = JVM_le_unfold[THEN meta_eq_to_obj_eq]

lemma err_code [code]:
  "Err.err A = Collect (case_err True (λx. x  A))"
by(auto simp add: err_def split: err.split)

lemma list_code [code]:
  "list n A = {xs. size xs = n  list_all (λx. x  A) xs}"
unfolding list_def
by(auto intro!: ext simp add: list_all_iff)

lemma opt_code [code]:
  "opt A = Collect (case_option True (λx. x  A))"
by(auto simp add: opt_def split: option.split)

lemma Times_code [code_unfold]:
  "Sigma A (%_. B) = {(a, b). a  A  b  B}"
by auto

lemma upto_esl_code [code]:
  "upto_esl m (A, r, f) = (Union ((λn. list n A) ` {..m}), Listn.le r, Listn.sup f)"
by(auto simp add: upto_esl_def)

lemmas [code] = lesub_def plussub_def

lemma JVM_sup_unfold [code]:
  "JVM_SemiType.sup S m n = 
  lift2 (Opt.sup (Product.sup (Listn.sup (SemiType.sup S)) (λx y. OK (map2 (lift2 (SemiType.sup S)) x y))))"
unfolding JVM_SemiType.sup_def JVM_SemiType.sl_def Opt.esl_def Err.sl_def
  stk_esl_def loc_sl_def Product.esl_def Listn.sl_def upto_esl_def 
  SemiType.esl_def Err.esl_def 
by simp

(* FIXME: why is @{thm sup_fun_def} declared [code del] in Lattices.thy? *)
declare sup_fun_def [code] 

lemma [code]: "states P mxs mxl = fst(sl P mxs mxl)"
unfolding states_def ..

lemma check_types_code [code]:
  "check_types P mxs mxl τs = (list_all (λx. x  (states P mxs mxl)) τs)"
unfolding check_types_def by(auto simp add: list_all_iff)

lemma wf_jvm_prog_code [code_unfold]:
  "wf_jvm_prog = wf_jvm_progk"
by(simp add: fun_eq_iff jvm_kildall_correct)

definition "wf_jvm_prog' = wf_jvm_prog"

(* Formal code generation test *)
ML_val @{code wf_jvm_prog'}

end

Theory BV_Main

theory BV_Main
imports
  JVMDeadlocked
  LBVJVM
  BCVExec
begin

end

Theory CallExpr

(*  Title:      JinjaThreads/Common/CallExpr.thy
    Author:     Andreas Lochbihler
*)

chapter ‹Compilation \label{cha:comp}›

section ‹Method calls in expressions›

theory CallExpr imports 
  "../J/Expr"
begin

fun inline_call :: "('a,'b,'addr) exp  ('a,'b,'addr) exp  ('a,'b,'addr) exp"
  and inline_calls :: "('a,'b,'addr) exp  ('a,'b,'addr) exp list  ('a,'b,'addr) exp list"
where
  "inline_call f (new C) = new C"
| "inline_call f (newA Te) = newA Tinline_call f e"
| "inline_call f (Cast C e) = Cast C (inline_call f e)"
| "inline_call f (e instanceof T) = (inline_call f e) instanceof T"
| "inline_call f (Val v) = Val v"
| "inline_call f (Var V) = Var V"
| "inline_call f (V:=e) = V := inline_call f e"
| "inline_call f (e «bop» e') = (if is_val e then (e «bop» inline_call f e') else (inline_call f e «bop» e'))"
| "inline_call f (ai) = (if is_val a then ainline_call f i else (inline_call f a)i)"
| "inline_call f (AAss a i e) =
   (if is_val a then if is_val i then AAss a i (inline_call f e) else AAss a (inline_call f i) e
    else AAss (inline_call f a) i e)"
| "inline_call f (a∙length) = inline_call f a∙length"
| "inline_call f (eF{D}) = inline_call f eF{D}"
| "inline_call f (FAss e F D e') = (if is_val e then FAss e F D (inline_call f e') else FAss (inline_call f e) F D e')"
| "inline_call f (CompareAndSwap e D F e' e'') = 
   (if is_val e then if is_val e' then CompareAndSwap e D F e' (inline_call f e'') 
     else CompareAndSwap e D F (inline_call f e') e''
    else CompareAndSwap (inline_call f e) D F e' e'')"
| "inline_call f (eM(es)) = 
   (if is_val e then if is_vals es  is_addr e then f else eM(inline_calls f es) else inline_call f eM(es))"
| "inline_call f ({V:T=vo; e}) = {V:T=vo; inline_call f e}"
| "inline_call f (syncV (o') e) = syncV (inline_call f o') e"
| "inline_call f (insyncV (a) e) = insyncV (a) (inline_call f e)"
| "inline_call f (e;;e') = inline_call f e;;e'"
| "inline_call f (if (b) e else e') = (if (inline_call f b) e else e')"
| "inline_call f (while (b) e) = while (b) e"
| "inline_call f (throw e) = throw (inline_call f e)"
| "inline_call f (try e1 catch(C V) e2) = try inline_call f e1 catch(C V) e2"

| "inline_calls f [] = []"
| "inline_calls f (e#es) = (if is_val e then e # inline_calls f es else inline_call f e # es)"

fun collapse :: "'addr expr × 'addr expr list  'addr expr" where
  "collapse (e, []) = e"
| "collapse (e, (e' # es)) = collapse (inline_call e e', es)"

definition is_call :: "('a, 'b, 'addr) exp  bool"
where "is_call e = (call e  None)"

definition is_calls :: "('a, 'b, 'addr) exp list  bool"
where "is_calls es = (calls es  None)"



lemma inline_calls_map_Val_append [simp]:
  "inline_calls f (map Val vs @ es) = map Val vs @ inline_calls f es"
by(induct vs, auto)

lemma inline_call_eq_Val_aux:
  "inline_call e E = Val v  call E = aMvs  e = Val v"
by(induct E)(auto split: if_split_asm)

lemmas inline_call_eq_Val [dest] = inline_call_eq_Val_aux inline_call_eq_Val_aux[OF sym, THEN sym]

lemma inline_calls_eq_empty [simp]: "inline_calls e es = []  es = []"
by(cases es, auto)

lemma inline_calls_map_Val [simp]: "inline_calls e (map Val vs) = map Val vs"
by(induct vs) auto

lemma  fixes E :: "('a,'b, 'addr) exp" and Es :: "('a,'b, 'addr) exp list"
  shows inline_call_eq_Throw [dest]: "inline_call e E = Throw a  call E = aMvs  e = Throw a  e = addr a"
by(induct E rule: exp.induct)(fastforce split:if_split_asm)+

lemma Throw_eq_inline_call_eq [dest]:
  "inline_call e E = Throw a  call E = aMvs  Throw a = e  addr a = e"
by(auto dest: inline_call_eq_Throw[OF sym])

lemma is_vals_inline_calls [dest]:
  " is_vals (inline_calls e es); calls es = aMvs   is_val e"
by(induct es, auto split: if_split_asm)

lemma [dest]: " inline_calls e es = map Val vs; calls es = aMvs   is_val e"
              " map Val vs = inline_calls e es; calls es = aMvs   is_val e"
by(fastforce intro!: is_vals_inline_calls del: is_val.intros simp add: is_vals_conv elim: sym)+

lemma inline_calls_eq_Val_Throw [dest]:
  " inline_calls e es = map Val vs @ Throw a # es'; calls es = aMvs   e = Throw a  is_val e"
apply(induct es arbitrary: vs a es')
apply(auto simp add: Cons_eq_append_conv split: if_split_asm)
done

lemma Val_Throw_eq_inline_calls [dest]:
  " map Val vs @ Throw a # es' = inline_calls e es; calls es = aMvs   Throw a = e  is_val e"
by(auto dest: inline_calls_eq_Val_Throw[OF sym])

declare option.split [split del] if_split_asm [split]  if_split [split del]

lemma call_inline_call [simp]:
  "call e = aMvs  call (inline_call {v:T=vo; e'} e) = call e'"
  "calls es = aMvs  calls (inline_calls {v:T=vo;e'} es) = call e'"
apply(induct e and es rule: call.induct calls.induct)
apply(fastforce)
apply(fastforce)
apply(fastforce)
apply(fastforce)
apply(fastforce)
apply(fastforce split: if_split)
apply(fastforce)
apply(fastforce)
apply(fastforce split: if_split)
apply(clarsimp)
 apply(fastforce split: if_split)
apply(fastforce split: if_split)
apply(fastforce)
apply(fastforce)
apply(fastforce split: if_split)
apply(fastforce split: if_split)
apply(fastforce split: if_split)
apply(fastforce)
apply(fastforce)
apply(fastforce)
apply(fastforce)
apply(fastforce)
apply(fastforce)
apply(fastforce)
apply(fastforce)
apply(fastforce)
apply(fastforce split: if_split)
done

declare option.split [split] if_split [split] if_split_asm [split del]

lemma fv_inline_call: "fv (inline_call e' e)  fv e  fv e'"
  and fvs_inline_calls: "fvs (inline_calls e' es)  fvs es  fv e'"
by(induct e and es rule: call.induct calls.induct)(fastforce split: if_split_asm)+

lemma contains_insync_inline_call_conv:
  "contains_insync (inline_call e e')  contains_insync e  call e'  None  contains_insync e'"
  and contains_insyncs_inline_calls_conv:
  "contains_insyncs (inline_calls e es')  contains_insync e  calls es'  None  contains_insyncs es'"
by(induct e' and es' rule: call.induct calls.induct)(auto split: if_split_asm simp add: is_vals_conv)

lemma contains_insync_inline_call [simp]:
  "call e' = aMvs  contains_insync (inline_call e e')  contains_insync e  contains_insync e'"
  and contains_insyncs_inline_calls [simp]:
  "calls es' = aMvs  contains_insyncs (inline_calls e es')  contains_insync e  contains_insyncs es'"
by(simp_all add: contains_insync_inline_call_conv contains_insyncs_inline_calls_conv)

lemma collapse_append [simp]:
  "collapse (e, es @ es') = collapse (collapse (e, es), es')"
by(induct es arbitrary: e, auto)

lemma collapse_conv_foldl:
  "collapse (e, es) = foldl inline_call e es"
by(induct es arbitrary: e) simp_all

lemma fv_collapse: "e  set es. is_call e  fv (collapse (e, es))  fvs (e # es)"
apply(induct es arbitrary: e)
apply(insert fv_inline_call)
apply(fastforce dest: subsetD)+
done

lemma final_inline_callD: " final (inline_call E e); is_call e   final E"
by(induct e)(auto simp add: is_call_def split: if_split_asm)

lemma collapse_finalD: " final (collapse (e, es)); eset es. is_call e   final e"
by(induct es arbitrary: e)(auto dest: final_inline_callD)

context heap_base begin

definition synthesized_call :: "'m prog  'heap  ('addr × mname × 'addr val list)  bool"
where
  "synthesized_call P h = 
   (λ(a, M, vs). T Ts Tr D. typeof_addr h a = T  P  class_type_of T sees M:TsTr = Native in D)"

lemma synthesized_call_conv:
  "synthesized_call P h (a, M, vs) = 
   (T Ts Tr D. typeof_addr h a = T  P  class_type_of T sees M:TsTr = Native in D)"
by(simp add: synthesized_call_def)

end

end

Theory J0

(*  Title:      JinjaThreads/Compiler/J0.thy
    Author:     Andreas Lochbihler
*)

section ‹The JinjaThreads source language with explicit call stacks›

theory J0 imports
  "../J/WWellForm"
  "../J/WellType"
  "../J/Threaded" 
  "../Framework/FWBisimulation" 
  CallExpr
begin

declare widen_refT [elim]

abbreviation final_expr0 :: "'addr expr × 'addr expr list  bool" where
  "final_expr0  λ(e, es). final e  es = []"

type_synonym
  ('addr, 'thread_id, 'heap) J0_thread_action = 
  "('addr, 'thread_id, 'addr expr × 'addr expr list,'heap) Jinja_thread_action"

type_synonym
  ('addr, 'thread_id, 'heap) J0_state = "('addr,'thread_id,'addr expr × 'addr expr list,'heap,'addr) state"

(* pretty printing for J_thread_action type *)
print_translation let
    fun tr'
       [a1, t
       , Const (@{type_syntax "prod"}, _) $ 
           (Const (@{type_syntax "exp"}, _) $
              Const (@{type_syntax "String.literal"}, _) $ Const (@{type_syntax "unit"}, _) $ a2) $
           (Const (@{type_syntax "list"}, _) $
              (Const (@{type_syntax "exp"}, _) $
                 Const (@{type_syntax "String.literal"}, _) $
                 Const (@{type_syntax "unit"}, _) $ a3))
       , h] =
      if a1 = a2 andalso a2 = a3 then Syntax.const @{type_syntax "J0_thread_action"} $ a1 $ t $ h
      else raise Match;
    in [(@{type_syntax "Jinja_thread_action"}, K tr')]
  end
typ "('addr,'thread_id,'heap) J0_thread_action"

(* pretty printing for J0_state type *)
print_translation let
    fun tr'
       [a1, t
       , Const (@{type_syntax "prod"}, _) $ 
           (Const (@{type_syntax "exp"}, _) $
              Const (@{type_syntax "String.literal"}, _) $ Const (@{type_syntax "unit"}, _) $ a2) $
           (Const (@{type_syntax "list"}, _) $
              (Const (@{type_syntax "exp"}, _) $
                 Const (@{type_syntax "String.literal"}, _) $
                 Const (@{type_syntax "unit"}, _) $ a3))
       , h, a4] =
      if a1 = a2 andalso a2 = a3 then Syntax.const @{type_syntax "J0_state"} $ a1 $ t $ h
      else raise Match;
    in [(@{type_syntax "state"}, K tr')]
  end
typ "('addr, 'thread_id, 'heap) J0_state"

definition extNTA2J0 :: "'addr J_prog  (cname × mname × 'addr)  ('addr expr × 'addr expr list)"
where
  "extNTA2J0 P = (λ(C, M, a). let (D, _, _, meth) = method P C M; (_, body) = the meth
                               in ({this:Class D=Addr a; body}, []))"

lemma extNTA2J0_iff [simp]:
  "extNTA2J0 P (C, M, a) = 
   ({this:Class (fst (method P C M))=Addr a; snd (the (snd (snd (snd (method P C M)))))}, [])"
by(simp add: extNTA2J0_def split_def)

abbreviation extTA2J0 :: 
  "'addr J_prog  ('addr, 'thread_id, 'heap) external_thread_action  ('addr, 'thread_id, 'heap) J0_thread_action"
where "extTA2J0 P  convert_extTA (extNTA2J0 P)"

lemma obs_a_extTA2J_eq_obs_a_extTA2J0 [simp]: "extTA2J P tao = extTA2J0 P tao"
by(cases ta)(simp add: ta_upd_simps)

lemma extTA2J0_ε: "extTA2J0 P ε = ε"
by(simp)

context J_heap_base begin

definition no_call :: "'m prog  'heap  ('a, 'b, 'addr) exp  bool"
where "no_call P h e = (aMvs. call e = aMvs  synthesized_call P h aMvs)"

definition no_calls :: "'m prog  'heap  ('a, 'b, 'addr) exp list  bool"
where "no_calls P h es = (aMvs. calls es = aMvs  synthesized_call P h aMvs)"

inductive red0 :: 
  "'addr J_prog  'thread_id  'addr expr  'addr expr list  'heap
   ('addr, 'thread_id, 'heap) J0_thread_action  'addr expr  'addr expr list  'heap  bool"
  ("_,_ ⊢0 ((1_'/_,/_) -_/ (1_'/_,/_))" [51,0,0,0,0,0,0,0,0] 81)
for P :: "'addr J_prog" and t :: 'thread_id
where

  red0Red:
  " extTA2J0 P,P,t  e, (h, Map.empty) -ta e', (h', xs');
     aMvs. call e = aMvs  synthesized_call P h aMvs 
   P,t ⊢0 e/es, h -ta e'/es, h'"

| red0Call:
  " call e = (a, M, vs); typeof_addr h a = U; 
     P  class_type_of U sees M:TsT = (pns, body) in D; 
     size vs = size pns; size Ts = size pns 
   P,t ⊢0 e/es, h -ε blocks (this # pns) (Class D # Ts) (Addr a # vs) body/e#es, h"

| red0Return:
  "final e'  P,t ⊢0 e'/e#es, h -ε inline_call e' e/es, h"

abbreviation J0_start_state :: "'addr J_prog  cname  mname  'addr val list  ('addr, 'thread_id, 'heap) J0_state"
where
  "J0_start_state  
   start_state (λC M Ts T (pns, body) vs. (blocks (this # pns) (Class C # Ts) (Null # vs) body, []))"

abbreviation mred0 ::
  "'addr J_prog  ('addr,'thread_id,'addr expr × 'addr expr list,'heap,'addr,('addr, 'thread_id) obs_event) semantics"
where "mred0 P  (λt ((e, es), h) ta ((e', es'), h'). red0 P t e es h ta e' es' h')"

end

declare domIff[iff, simp del]

context J_heap_base begin

lemma assumes wf: "wwf_J_prog P"
  shows red_fv_subset: "extTA,P,t  e, s -ta e', s'  fv e'  fv e"
  and reds_fvs_subset: "extTA,P,t  es, s [-ta→] es', s'  fvs es'  fvs es"
proof(induct rule: red_reds.inducts)
  case (RedCall s a U M Ts T pns body D vs)
  hence "fv body  {this}  set pns"
    using wf by(fastforce dest!:sees_wf_mdecl simp:wf_mdecl_def)
  with RedCall show ?case by fastforce
next
  case RedCallExternal thus ?case by(auto simp add: extRet2J_def split: extCallRet.split_asm)
qed(fastforce)+

end

declare domIff[iff del]

context J_heap_base begin

lemma assumes wwf: "wwf_J_prog P"
  shows red_fv_ok: " extTA,P,t  e, s -ta e', s'; fv e  dom (lcl s)   fv e'  dom (lcl s')"
  and reds_fvs_ok: " extTA,P,t  es, s [-ta→] es', s'; fvs es  dom (lcl s)   fvs es'  dom (lcl s')"
proof(induct rule: red_reds.inducts)
  case (RedCall s a U M Ts T pns body D vs)
  from P  class_type_of U sees M: TsT = (pns, body) in D have "wwf_J_mdecl P D (M,Ts,T,pns,body)"
    by(auto dest!: sees_wf_mdecl[OF wwf] simp add: wf_mdecl_def)
  with RedCall show ?case by(auto)
next
  case RedCallExternal thus ?case by(auto simp add: extRet2J_def split: extCallRet.split_asm)
next
  case (BlockRed e h x V vo ta e' h' x' T)
  note red = extTA,P,t  e,(h, x(V := vo)) -ta e',(h', x')
  hence "fv e'  fv e" by(auto dest: red_fv_subset[OF wwf] del: subsetI)
  moreover from ‹ fv {V:T=vo; e}  dom (lcl (h, x))
  have "fv e - {V}  dom x" by(simp)
  ultimately have "fv e' - {V}  dom x - {V}" by(auto)
  moreover from red have "dom (x(V := vo))  dom x'"
    by(auto dest: red_lcl_incr del: subsetI)
  ultimately have "fv e' - {V}  dom x' - {V}"
    by(auto split: if_split_asm)
  thus ?case by(auto simp del: fun_upd_apply)
qed(fastforce dest: red_lcl_incr del: subsetI)+

lemma is_call_red_state_unchanged: 
  " extTA,P,t  e, s -ta e', s'; call e = aMvs; ¬ synthesized_call P (hp s) aMvs   s' = s  ta = ε"

  and is_calls_reds_state_unchanged:
  " extTA,P,t  es, s [-ta→] es', s'; calls es = aMvs; ¬ synthesized_call P (hp s) aMvs   s' = s  ta = ε"
apply(induct rule: red_reds.inducts)
apply(fastforce split: if_split_asm simp add: synthesized_call_def)+
done

lemma called_methodD:
  " extTA,P,t  e, s -ta e', s'; call e = (a, M, vs); ¬ synthesized_call P (hp s) (a, M, vs)  
   hT D Us U pns body. hp s' = hp s  typeof_addr (hp s) a = hT 
                           P  class_type_of hT sees M: UsU = (pns, body) in D  
                           length vs = length pns  length Us = length pns"

  and called_methodsD:
  " extTA,P,t  es, s [-ta→] es', s'; calls es = (a, M, vs); ¬ synthesized_call P (hp s) (a, M, vs)  
   hT D Us U pns body. hp s' = hp s  typeof_addr (hp s) a = hT 
                           P  class_type_of hT sees M: UsU = (pns, body) in D 
                           length vs = length pns  length Us = length pns"
apply(induct rule: red_reds.inducts)
apply(auto split: if_split_asm simp add: synthesized_call_def)
apply(fastforce)
done

subsection ‹Silent moves›

primrec  τmove0 :: "'m prog  'heap  ('a, 'b, 'addr) exp  bool"
  and τmoves0 :: "'m prog  'heap  ('a, 'b, 'addr) exp list  bool"
where
  "τmove0 P h (new C)  False"
| "τmove0 P h (newA Te)  τmove0 P h e  (a. e = Throw a)"
| "τmove0 P h (Cast U e)  τmove0 P h e  (a. e = Throw a)  (v. e = Val v)"
| "τmove0 P h (e instanceof T)  τmove0 P h e  (a. e = Throw a)  (v. e = Val v)"
| "τmove0 P h (e «bop» e')  τmove0 P h e  (a. e = Throw a)  (v. e = Val v 
   (τmove0 P h e'  (a. e' = Throw a)  (v. e' = Val v)))"
| "τmove0 P h (Val v)  False"
| "τmove0 P h (Var V)  True"
| "τmove0 P h (V := e)  τmove0 P h e  (a. e = Throw a)  (v. e = Val v)"
| "τmove0 P h (ai)  τmove0 P h a  (ad. a = Throw ad)  (v. a = Val v  (τmove0 P h i  (a. i = Throw a)))"
| "τmove0 P h (AAss a i e)  τmove0 P h a  (ad. a = Throw ad)  (v. a = Val v  
   (τmove0 P h i  (a. i = Throw a)  (v. i = Val v  (τmove0 P h e  (a. e = Throw a)))))"
| "τmove0 P h (a∙length)  τmove0 P h a  (ad. a = Throw ad)"
| "τmove0 P h (eF{D})  τmove0 P h e  (a. e = Throw a)"
| "τmove0 P h (FAss e F D e')  τmove0 P h e  (a. e = Throw a)  (v. e = Val v  (τmove0 P h e'  (a. e' = Throw a)))"
| "τmove0 P h (e∙compareAndSwap(DF, e', e''))  τmove0 P h e  (a. e = Throw a)  (v. e = Val v 
   (τmove0 P h e'  (a. e' = Throw a)  (v. e' = Val v  (τmove0 P h e''  (a. e'' = Throw a)))))"
| "τmove0 P h (eM(es))  τmove0 P h e  (a. e = Throw a)  (v. e = Val v 
   ((τmoves0 P h es  (vs a es'. es = map Val vs @ Throw a # es'))  
    (vs. es = map Val vs  (v = Null  (T C Ts Tr D. typeofh v = T  class_type_of' T = C  P  C sees M:TsTr = Native in D  τexternal_defs D M)))))"
| "τmove0 P h ({V:T=vo; e})  τmove0 P h e  ((a. e = Throw a)  (v. e = Val v))"
| "τmove0 P h (syncV'(e) e')  τmove0 P h e  (a. e = Throw a)"
| "τmove0 P h (insyncV'(ad) e)  τmove0 P h e"
| "τmove0 P h (e;;e')  τmove0 P h e  (a. e = Throw a)  (v. e = Val v)"
| "τmove0 P h (if (e) e' else e'')  τmove0 P h e  (a. e = Throw a)  (v. e = Val v)"
| "τmove0 P h (while (e) e') = True"
| ― ‹@{term "Throw a"} is no @{text "τmove0"} because there is no reduction for it.
  If it were, most defining equations would be simpler. However, @{term "insyncV'(ad) (Throw ad)"}
  must not be a @{text "τmove0"}, but would be if @{term "Throw a"} was.›
  "τmove0 P h (throw e)  τmove0 P h e  (a. e = Throw a)  e = null"
| "τmove0 P h (try e catch(C V) e')  τmove0 P h e  (a. e = Throw a)  (v. e = Val v)"

| "τmoves0 P h []  False"
| "τmoves0 P h (e # es)  τmove0 P h e  (v. e = Val v  τmoves0 P h es)"

abbreviation τMOVE :: "'m prog  (('addr expr × 'addr locals) × 'heap, ('addr, 'thread_id, 'heap) J_thread_action) trsys"
where "τMOVE  λP ((e, x), h) ta s'. τmove0 P h e  ta = ε"

primrec τMove0 :: "'m prog  'heap  ('addr expr × 'addr expr list)  bool"
where
  "τMove0 P h (e, exs) = (τmove0 P h e  final e)"
  
abbreviation τMOVE0 :: "'m prog  (('addr expr × 'addr expr list) × 'heap, ('addr, 'thread_id, 'heap) J0_thread_action) trsys"
where "τMOVE0  λP (es, h) ta s. τMove0 P h es  ta = ε"

definition τred0 ::
  "(('addr, 'thread_id, 'heap) external_thread_action  ('addr, 'thread_id, 'x,'heap) Jinja_thread_action)
   'addr J_prog  'thread_id  'heap  ('addr expr × 'addr locals)  ('addr expr × 'addr locals)  bool"
where
  "τred0 extTA P t h exs e'xs' =
   (extTA,P,t  fst exs, (h, snd exs) -ε fst e'xs', (h, snd e'xs')  τmove0 P h (fst exs)  no_call P h (fst exs))"

definition τreds0 :: 
  "(('addr, 'thread_id, 'heap) external_thread_action  ('addr, 'thread_id, 'x,'heap) Jinja_thread_action) 
   'addr J_prog  'thread_id  'heap  ('addr expr list × 'addr locals)  ('addr expr list × 'addr locals)  bool"
where 
  "τreds0 extTA P t h esxs es'xs' = 
   (extTA,P,t  fst esxs, (h, snd esxs) [-ε→] fst es'xs', (h, snd es'xs')  τmoves0 P h (fst esxs) 
    no_calls P h (fst esxs))"

abbreviation τred0t ::
  "(('addr, 'thread_id, 'heap) external_thread_action  ('addr, 'thread_id, 'x,'heap) Jinja_thread_action) 
   'addr J_prog  'thread_id  'heap  ('addr expr × 'addr locals)  ('addr expr × 'addr locals)  bool"
where "τred0t extTA P t h  (τred0 extTA P t h)^++"

abbreviation τreds0t ::
  "(('addr, 'thread_id, 'heap) external_thread_action  ('addr, 'thread_id, 'x,'heap) Jinja_thread_action) 
   'addr J_prog  'thread_id  'heap  ('addr expr list × 'addr locals)  ('addr expr list × 'addr locals)  bool"
where "τreds0t extTA P t h  (τreds0 extTA P t h)^++"

abbreviation τred0r :: 
  "(('addr, 'thread_id, 'heap) external_thread_action  ('addr, 'thread_id, 'x,'heap) Jinja_thread_action) 
   'addr J_prog  'thread_id  'heap  ('addr expr × 'addr locals)  ('addr expr × 'addr locals)  bool"
where "τred0r extTA P t h  (τred0 extTA P t h)^**"

abbreviation τreds0r :: 
  "(('addr, 'thread_id, 'heap) external_thread_action  ('addr, 'thread_id, 'x,'heap) Jinja_thread_action)
   'addr J_prog  'thread_id  'heap  ('addr expr list × 'addr locals)  ('addr expr list × 'addr locals)  bool"
where "τreds0r extTA P t h  (τreds0 extTA P t h)^**"

definition τRed0 :: 
  "'addr J_prog  'thread_id  'heap  ('addr expr × 'addr expr list)  ('addr expr × 'addr expr list)  bool"
where "τRed0 P t h ees e'es' = (P,t ⊢0 fst ees/snd ees, h -ε fst e'es'/snd e'es', h  τMove0 P h ees)"

abbreviation τRed0r ::
  "'addr J_prog  'thread_id  'heap  ('addr expr × 'addr expr list)  ('addr expr × 'addr expr list)  bool"
where "τRed0r P t h  (τRed0 P t h)^**"

abbreviation τRed0t ::
  "'addr J_prog  'thread_id  'heap  ('addr expr × 'addr expr list)  ('addr expr × 'addr expr list)  bool"
where "τRed0t P t h  (τRed0 P t h)^++"

lemma τmove0_τmoves0_intros:
  fixes e e1 e2 e' :: "('a, 'b, 'addr) exp" and es :: "('a, 'b, 'addr) exp list"
  shows τmove0NewArray: "τmove0 P h e  τmove0 P h (newA Te)"
  and τmove0Cast: "τmove0 P h e  τmove0 P h (Cast U e)"
  and τmove0CastRed: "τmove0 P h (Cast U (Val v))"
  and τmove0InstanceOf: "τmove0 P h e  τmove0 P h (e instanceof T)"
  and τmove0InstanceOfRed: "τmove0 P h ((Val v) instanceof T)"
  and τmove0BinOp1: "τmove0 P h e  τmove0 P h (e«bop»e')"
  and τmove0BinOp2: "τmove0 P h e  τmove0 P h (Val v«bop»e)"
  and τmove0BinOp: "τmove0 P h (Val v«bop»Val v')"
  and τmove0Var: "τmove0 P h (Var V)"
  and τmove0LAss: "τmove0 P h e  τmove0 P h (V := e)"
  and τmove0LAssRed: "τmove0 P h (V := Val v)"
  and τmove0AAcc1: "τmove0 P h e  τmove0 P h (ee')"
  and τmove0AAcc2: "τmove0 P h e  τmove0 P h (Val ve)"
  and τmove0AAss1: "τmove0 P h e  τmove0 P h (ee1 := e2)"
  and τmove0AAss2: "τmove0 P h e  τmove0 P h (Val ve := e')"
  and τmove0AAss3: "τmove0 P h e  τmove0 P h (Val vVal v' := e)"
  and τmove0ALength: "τmove0 P h e  τmove0 P h (e∙length)"
  and τmove0FAcc: "τmove0 P h e  τmove0 P h (eF{D})"
  and τmove0FAss1: "τmove0 P h e  τmove0 P h (FAss e F D e')"
  and τmove0FAss2: "τmove0 P h e  τmove0 P h (Val vF{D} := e)"
  and τmove0CAS1: "τmove0 P h e  τmove0 P h (e∙compareAndSwap(DF, e', e''))"
  and τmove0CAS2: "τmove0 P h e'  τmove0 P h (Val v∙compareAndSwap(DF, e', e''))"
  and τmove0CAS3: "τmove0 P h e''  τmove0 P h (Val v∙compareAndSwap(DF, Val v', e''))"
  and τmove0CallObj: "τmove0 P h e  τmove0 P h (eM(es))"
  and τmove0CallParams: "τmoves0 P h es  τmove0 P h (Val vM(es))"
  and τmove0Call: "(T C Ts Tr D.  typeofh v = T; class_type_of' T = C; P  C sees M:TsTr = Native in D   τexternal_defs D M)  τmove0 P h (Val vM(map Val vs))"
  and τmove0Block: "τmove0 P h e  τmove0 P h {V:T=vo; e}"
  and τmove0BlockRed: "τmove0 P h {V:T=vo; Val v}"
  and τmove0Sync: "τmove0 P h e  τmove0 P h (syncV' (e) e')"
  and τmove0InSync: "τmove0 P h e  τmove0 P h (insyncV' (a) e)"
  and τmove0Seq: "τmove0 P h e  τmove0 P h (e;;e')"
  and τmove0SeqRed: "τmove0 P h (Val v;; e')"
  and τmove0Cond: "τmove0 P h e  τmove0 P h (if (e) e1 else e2)"
  and τmove0CondRed: "τmove0 P h (if (Val v) e1 else e2)"
  and τmove0WhileRed: "τmove0 P h (while (e) e')"
  and τmove0Throw: "τmove0 P h e  τmove0 P h (throw e)"
  and τmove0ThrowNull: "τmove0 P h (throw null)"
  and τmove0Try: "τmove0 P h e  τmove0 P h (try e catch(C V) e')"
  and τmove0TryRed: "τmove0 P h (try Val v catch(C V) e)"
  and τmove0TryThrow: "τmove0 P h (try Throw a catch(C V) e)"
  and τmove0NewArrayThrow: "τmove0 P h (newA TThrow a)"
  and τmove0CastThrow: "τmove0 P h (Cast T (Throw a))"
  and τmove0CInstanceOfThrow: "τmove0 P h ((Throw a) instanceof T)"
  and τmove0BinOpThrow1: "τmove0 P h (Throw a «bop» e')"
  and τmove0BinOpThrow2: "τmove0 P h (Val v «bop» Throw a)"
  and τmove0LAssThrow: "τmove0 P h (V:=(Throw a))"
  and τmove0AAccThrow1: "τmove0 P h (Throw ae)"
  and τmove0AAccThrow2: "τmove0 P h (Val vThrow a)"
  and τmove0AAssThrow1: "τmove0 P h (AAss (Throw a) e e')"
  and τmove0AAssThrow2: "τmove0 P h (AAss (Val v) (Throw a) e')"
  and τmove0AAssThrow3: "τmove0 P h (AAss (Val v) (Val v') (Throw a))"
  and τmove0ALengthThrow: "τmove0 P h (Throw a∙length)"
  and τmove0FAccThrow: "τmove0 P h (Throw aF{D})"
  and τmove0FAssThrow1: "τmove0 P h (Throw aF{D} := e)"
  and τmove0FAssThrow2: "τmove0 P h (FAss (Val v) F D (Throw a))"
  and τmove0CallThrowObj: "τmove0 P h (Throw aM(es))"
  and τmove0CallThrowParams: "τmove0 P h (Val vM(map Val vs @ Throw a # es))"
  and τmove0BlockThrow: "τmove0 P h {V:T=vo; Throw a}"
  and τmove0SyncThrow: "τmove0 P h (syncV' (Throw a) e)"
  and τmove0SeqThrow: "τmove0 P h (Throw a;;e)"
  and τmove0CondThrow: "τmove0 P h (if (Throw a) e1 else e2)"
  and τmove0ThrowThrow: "τmove0 P h (throw (Throw a))"

  and τmoves0Hd: "τmove0 P h e  τmoves0 P h (e # es)"
  and τmoves0Tl: "τmoves0 P h es  τmoves0 P h (Val v # es)"
by auto

lemma τmoves0_map_Val [iff]:
  "¬ τmoves0 P h (map Val vs)"
by(induct vs) auto

lemma τmoves0_map_Val_append [simp]:
  "τmoves0 P h (map Val vs @ es) = τmoves0 P h es"
by(induct vs)(auto)

lemma no_reds_map_Val_Throw [simp]:
  "extTA,P,t  map Val vs @ Throw a # es, s [-ta→] es', s' = False"
by(induct vs arbitrary: es')(auto elim: reds.cases)

lemma assumes [simp]: "extTA ε = ε"
  shows red_τ_taD: " extTA,P,t  e, s -ta e', s'; τmove0 P (hp s) e   ta = ε"
  and reds_τ_taD: " extTA,P,t  es, s [-ta→] es', s'; τmoves0 P (hp s) es   ta = ε"
apply(induct rule: red_reds.inducts)
apply(fastforce simp add: map_eq_append_conv τexternal'_def τexternal_def dest: τexternal'_red_external_TA_empty)+
done

lemma τmove0_heap_unchanged: " extTA,P,t  e, s -ta e', s'; τmove0 P (hp s) e   hp s' = hp s"
  and τmoves0_heap_unchanged: " extTA,P,t  es, s [-ta→] es', s'; τmoves0 P (hp s) es   hp s' = hp s"
apply(induct rule: red_reds.inducts)
apply(auto)
apply(fastforce simp add: map_eq_append_conv τexternal'_def τexternal_def dest: τexternal'_red_external_heap_unchanged)+
done

lemma τMove0_iff:
  "τMove0 P h ees  (let (e, _) = ees in τmove0 P h e  final e)"
by(cases ees)(simp)

lemma no_call_simps [simp]:
  "no_call P h (new C) = True"
  "no_call P h (newA Te) = no_call P h e"
  "no_call P h (Cast T e) = no_call P h e"
  "no_call P h (e instanceof T) = no_call P h e"
  "no_call P h (Val v) = True"
  "no_call P h (Var V) = True"
  "no_call P h (V := e) = no_call P h e"
  "no_call P h (e «bop» e') = (if is_val e then no_call P h e' else no_call P h e)"
  "no_call P h (ai) = (if is_val a then no_call P h i else no_call P h a)"
  "no_call P h (AAss a i e) = (if is_val a then (if is_val i then no_call P h e else no_call P h i) else no_call P h a)"
  "no_call P h (a∙length) = no_call P h a"
  "no_call P h (eF{D}) = no_call P h e"
  "no_call P h (FAss e F D e') = (if is_val e then no_call P h e' else no_call P h e)"
  "no_call P h (e∙compareAndSwap(DF, e', e'')) = (if is_val e then (if is_val e' then no_call P h e'' else no_call P h e') else no_call P h e)"
  "no_call P h (eM(es)) = (if is_val e then (if is_vals es  is_addr e then synthesized_call P h (THE a. e = addr a, M, THE vs. es = map Val vs) else no_calls P h es) else no_call P h e)"
  "no_call P h ({V:T=vo; e}) = no_call P h e"
  "no_call P h (syncV' (e) e') = no_call P h e"
  "no_call P h (insyncV' (ad) e) = no_call P h e"
  "no_call P h (e;;e') = no_call P h e"
  "no_call P h (if (e) e1 else e2) = no_call P h e"
  "no_call P h (while(e) e') = True"
  "no_call P h (throw e) = no_call P h e"
  "no_call P h (try e catch(C V) e') = no_call P h e"
by(auto simp add: no_call_def no_calls_def)

lemma no_calls_simps [simp]:
  "no_calls P h [] = True"
  "no_calls P h (e # es) = (if is_val e then no_calls P h es else no_call P h e)"
by(simp_all add: no_call_def no_calls_def)

lemma no_calls_map_Val [simp]:
  "no_calls P h (map Val vs)"
by(induct vs) simp_all

lemma assumes nfin: "¬ final e'"
 shows inline_call_τmove0_inv: "call e = aMvs  τmove0 P h (inline_call e' e) = τmove0 P h e'"
  and inline_calls_τmoves0_inv: "calls es = aMvs  τmoves0 P h (inline_calls e' es) = τmove0 P h e'"
apply(induct e and es rule: τmove0.induct τmoves0.induct)
apply(insert nfin)
apply simp_all
apply auto
done

lemma τred0_iff [iff]:
  "τred0 extTA P t h (e, xs) (e', xs') = (extTA,P,t  e, (h, xs) -ε e', (h, xs')  τmove0 P h e  no_call P h e)"
by(simp add: τred0_def)

lemma τreds0_iff [iff]:
  "τreds0 extTA P t h (es, xs) (es', xs') =
  (extTA,P,t  es, (h, xs) [-ε→] es', (h, xs')  τmoves0 P h es  no_calls P h es)"
by(simp add: τreds0_def)

lemma τred0t_1step:
  " extTA,P,t  e, (h, xs) -ε e', (h, xs'); τmove0 P h e; no_call P h e 
   τred0t extTA P t h (e, xs) (e', xs')"
by(blast intro: tranclp.r_into_trancl)

lemma τred0t_2step:
  " extTA,P,t  e, (h, xs) -ε e', (h, xs'); τmove0 P h e; no_call P h e;
     extTA,P,t  e', (h, xs') -ε e'', (h, xs''); τmove0 P h e'; no_call P h e' 
   τred0t extTA P t h (e, xs) (e'', xs'')"
by(blast intro: tranclp.trancl_into_trancl[OF τred0t_1step])

lemma τred1t_3step:
  " extTA,P,t  e, (h, xs) -ε e', (h, xs'); τmove0 P h e; no_call P h e; 
     extTA,P,t  e', (h, xs') -ε e'', (h, xs''); τmove0 P h e'; no_call P h e';
     extTA,P,t  e'', (h, xs'') -ε e''', (h, xs'''); τmove0 P h e''; no_call P h e'' 
   τred0t extTA P t h (e, xs) (e''', xs''')"
by(blast intro: tranclp.trancl_into_trancl[OF τred0t_2step])

lemma τreds0t_1step:
  " extTA,P,t  es, (h, xs) [-ε→] es', (h, xs'); τmoves0 P h es; no_calls P h es 
   τreds0t extTA P t h (es, xs) (es', xs')"
by(blast intro: tranclp.r_into_trancl)

lemma τreds0t_2step:
  " extTA,P,t  es, (h, xs) [-ε→] es', (h, xs'); τmoves0 P h es; no_calls P h es; 
     extTA,P,t  es', (h, xs') [-ε→] es'', (h, xs''); τmoves0 P h es'; no_calls P h es' 
   τreds0t extTA P t h (es, xs) (es'', xs'')"
by(blast intro: tranclp.trancl_into_trancl[OF τreds0t_1step])

lemma τreds0t_3step:
  " extTA,P,t  es, (h, xs) [-ε→] es', (h, xs'); τmoves0 P h es; no_calls P h es; 
     extTA,P,t  es', (h, xs') [-ε→] es'', (h, xs''); τmoves0 P h es'; no_calls P h es';
     extTA,P,t  es'', (h, xs'') [-ε→] es''', (h, xs'''); τmoves0 P h es''; no_calls P h es'' 
   τreds0t extTA P t h (es, xs) (es''', xs''')"
by(blast intro: tranclp.trancl_into_trancl[OF τreds0t_2step])

lemma τred0r_1step:
  " extTA,P,t  e, (h, xs) -ε e', (h, xs'); τmove0 P h e; no_call P h e 
   τred0r extTA P t h (e, xs) (e', xs')"
by(blast intro: r_into_rtranclp)

lemma τred0r_2step:
  " extTA,P,t  e, (h, xs) -ε e', (h, xs'); τmove0 P h e; no_call P h e;
     extTA,P,t  e', (h, xs') -ε e'', (h, xs''); τmove0 P h e'; no_call P h e' 
   τred0r extTA P t h (e, xs) (e'', xs'')"
by(blast intro: rtranclp.rtrancl_into_rtrancl[OF τred0r_1step])

lemma τred0r_3step:
  " extTA,P,t  e, (h, xs) -ε e', (h, xs'); τmove0 P h e; no_call P h e; 
     extTA,P,t  e', (h, xs') -ε e'', (h, xs''); τmove0 P h e'; no_call P h e';
     extTA,P,t  e'', (h, xs'') -ε e''', (h, xs'''); τmove0 P h e''; no_call P h e'' 
   τred0r extTA P t h (e, xs) (e''', xs''')"
by(blast intro: rtranclp.rtrancl_into_rtrancl[OF τred0r_2step])

lemma τreds0r_1step:
  " extTA,P,t  es, (h, xs) [-ε→] es', (h, xs'); τmoves0 P h es; no_calls P h es 
   τreds0r extTA P t h (es, xs) (es', xs')"
by(blast intro: r_into_rtranclp)

lemma τreds0r_2step:
  " extTA,P,t  es, (h, xs) [-ε→] es', (h, xs'); τmoves0 P h es; no_calls P h es; 
     extTA,P,t  es', (h, xs') [-ε→] es'', (h, xs''); τmoves0 P h es'; no_calls P h es' 
   τreds0r extTA P t h (es, xs) (es'', xs'')"
by(blast intro: rtranclp.rtrancl_into_rtrancl[OF τreds0r_1step])

lemma τreds0r_3step:
  " extTA,P,t  es, (h, xs) [-ε→] es', (h, xs'); τmoves0 P h es; no_calls P h es; 
     extTA,P,t  es', (h, xs') [-ε→] es'', (h, xs''); τmoves0 P h es'; no_calls P h es';
     extTA,P,t  es'', (h, xs'') [-ε→] es''', (h, xs'''); τmoves0 P h es''; no_calls P h es'' 
   τreds0r extTA P t h (es, xs) (es''', xs''')"
by(blast intro: rtranclp.rtrancl_into_rtrancl[OF τreds0r_2step])

lemma τred0t_inj_τreds0t:
  "τred0t extTA P t h (e, xs) (e', xs')
   τreds0t extTA P t h (e # es, xs) (e' # es, xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl ListRed1)

lemma τreds0t_cons_τreds0t:
  "τreds0t extTA P t h (es, xs) (es', xs')
   τreds0t extTA P t h (Val v # es, xs) (Val v # es', xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl ListRed2)

lemma τred0r_inj_τreds0r:
  "τred0r extTA P t h (e, xs) (e', xs')
   τreds0r extTA P t h (e # es, xs) (e' # es, xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl ListRed1)

lemma τreds0r_cons_τreds0r:
  "τreds0r extTA P t h (es, xs) (es', xs') 
   τreds0r extTA P t h (Val v # es, xs) (Val v # es', xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl ListRed2)

lemma NewArray_τred0t_xt:
  "τred0t extTA P t h (e, xs) (e', xs')
   τred0t extTA P t h (newA Te, xs) (newA Te', xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl NewArrayRed)

lemma Cast_τred0t_xt:
  "τred0t extTA P t h (e, xs) (e', xs')  τred0t extTA P t h (Cast T e, xs) (Cast T e', xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl CastRed)

lemma InstanceOf_τred0t_xt:
  "τred0t extTA P t h (e, xs) (e', xs')  τred0t extTA P t h (e instanceof T, xs) (e' instanceof T, xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl InstanceOfRed)

lemma BinOp_τred0t_xt1:
  "τred0t extTA P t h (e1, xs) (e1', xs')  τred0t extTA P t h (e1 «bop» e2, xs) (e1' «bop» e2, xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl BinOpRed1)

lemma BinOp_τred0t_xt2:
  "τred0t extTA P t h (e2, xs) (e2', xs')  τred0t extTA P t h (Val v «bop» e2, xs) (Val v «bop» e2', xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl BinOpRed2)

lemma LAss_τred0t:
  "τred0t extTA P t h (e, xs) (e', xs')  τred0t extTA P t h (V := e, xs) (V := e', xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl LAssRed)

lemma AAcc_τred0t_xt1:
  "τred0t extTA P t h (a, xs) (a', xs')  τred0t extTA P t h (ai, xs) (a'i, xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl AAccRed1)

lemma AAcc_τred0t_xt2:
  "τred0t extTA P t h (i, xs) (i', xs')  τred0t extTA P t h (Val ai, xs) (Val ai', xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl AAccRed2)

lemma AAss_τred0t_xt1:
  "τred0t extTA P t h (a, xs) (a', xs')  τred0t extTA P t h (ai := e, xs) (a'i := e, xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl AAssRed1)

lemma AAss_τred0t_xt2:
  "τred0t extTA P t h (i, xs) (i', xs')  τred0t extTA P t h (Val ai := e, xs) (Val ai' := e, xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl AAssRed2)

lemma AAss_τred0t_xt3:
  "τred0t extTA P t h (e, xs) (e', xs')  τred0t extTA P t h (Val aVal i := e, xs) (Val aVal i := e', xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl AAssRed3)

lemma ALength_τred0t_xt:
  "τred0t extTA P t h (a, xs) (a', xs')  τred0t extTA P t h (a∙length, xs) (a'∙length, xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl ALengthRed)

lemma FAcc_τred0t_xt:
  "τred0t extTA P t h (e, xs) (e', xs')  τred0t extTA P t h (eF{D}, xs) (e'F{D}, xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl FAccRed)

lemma FAss_τred0t_xt1:
  "τred0t extTA P t h (e, xs) (e', xs')  τred0t extTA P t h (eF{D} := e2, xs) (e'F{D} := e2, xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl FAssRed1)

lemma FAss_τred0t_xt2:
  "τred0t extTA P t h (e, xs) (e', xs')  τred0t extTA P t h (Val vF{D} := e, xs) (Val vF{D} := e', xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl FAssRed2)

lemma CAS_τred0t_xt1:
  "τred0t extTA P t h (e, xs) (e', xs')  τred0t extTA P t h (e∙compareAndSwap(DF, e2, e3), xs) (e'∙compareAndSwap(DF, e2, e3), xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl CASRed1)

lemma CAS_τred0t_xt2:
  "τred0t extTA P t h (e, xs) (e', xs')  τred0t extTA P t h (Val v∙compareAndSwap(DF, e, e3), xs) (Val v∙compareAndSwap(DF, e', e3), xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl CASRed2)

lemma CAS_τred0t_xt3:
  "τred0t extTA P t h (e, xs) (e', xs')  τred0t extTA P t h (Val v∙compareAndSwap(DF, Val v', e), xs) (Val v∙compareAndSwap(DF, Val v', e'), xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl CASRed3)

lemma Call_τred0t_obj:
  "τred0t extTA P t h (e, xs) (e', xs')  τred0t extTA P t h (eM(ps), xs) (e'M(ps), xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl CallObj)

lemma Call_τred0t_param:
  "τreds0t extTA P t h (es, xs) (es', xs')  τred0t extTA P t h (Val vM(es), xs) (Val vM(es'), xs')"
by(induct rule: tranclp_induct2)(fastforce intro: tranclp.trancl_into_trancl CallParams)+

lemma Block_τred0t_xt:
  "τred0t extTA P t h (e, xs(V := vo)) (e', xs')  τred0t extTA P t h ({V:T=vo; e}, xs) ({V:T=xs' V; e'}, xs'(V := xs V))"
proof(induct rule: tranclp_induct2)
  case base thus ?case by(auto intro: BlockRed simp del: fun_upd_apply)
next
  case (step e' xs' e'' xs'')
  from ‹τred0 extTA P t h (e', xs') (e'', xs'') 
  have "extTA,P,t  e',(h, xs') -ε e'',(h, xs'')" "τmove0 P h e'" "no_call P h e'" by auto
  hence "extTA,P,t  e',(h, xs'(V := xs V, V := xs' V)) -ε e'',(h, xs'')" by simp
  from BlockRed[OF this, of T] ‹τmove0 P h e' ‹no_call P h e'
  have "τred0 extTA P t h ({V:T=xs' V; e'}, xs'(V := xs V)) ({V:T=xs'' V; e''}, xs''(V := xs V))" by(auto)
  with ‹τred0t extTA P t h ({V:T=vo; e}, xs) ({V:T=xs' V; e'}, xs'(V := xs V)) show ?case ..
qed

lemma Sync_τred0t_xt:
  "τred0t extTA P t h (e, xs) (e', xs')  τred0t extTA P t h (syncV (e) e2, xs) (syncV (e') e2, xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl SynchronizedRed1)

lemma InSync_τred0t_xt:
  "τred0t extTA P t h (e, xs) (e', xs')  τred0t extTA P t h (insyncV (a) e, xs) (insyncV (a) e', xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl SynchronizedRed2)

lemma Seq_τred0t_xt:
  "τred0t extTA P t h (e, xs) (e', xs')  τred0t extTA P t h (e;;e2, xs) (e';;e2, xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl SeqRed)

lemma Cond_τred0t_xt:
  "τred0t extTA P t h (e, xs) (e', xs')  τred0t extTA P t h (if (e) e1 else e2, xs) (if (e') e1 else e2, xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl CondRed)

lemma Throw_τred0t_xt:
  "τred0t extTA P t h (e, xs) (e', xs')  τred0t extTA P t h (throw e, xs) (throw e', xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl ThrowRed)

lemma Try_τred0t_xt:
  "τred0t extTA P t h (e, xs) (e', xs')  τred0t extTA P t h (try e catch(C V) e2, xs) (try e' catch(C V) e2, xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl TryRed)

lemma NewArray_τred0r_xt:
  "τred0r extTA P t h (e, xs) (e', xs')  τred0r extTA P t h (newA Te, xs) (newA Te', xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl NewArrayRed)

lemma Cast_τred0r_xt:
  "τred0r extTA P t h (e, xs) (e', xs')  τred0r extTA P t h (Cast T e, xs) (Cast T e', xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl CastRed)

lemma InstanceOf_τred0r_xt:
  "τred0r extTA P t h (e, xs) (e', xs')  τred0r extTA P t h (e instanceof T, xs) (e' instanceof T, xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl InstanceOfRed)

lemma BinOp_τred0r_xt1:
  "τred0r extTA P t h (e1, xs) (e1', xs')  τred0r extTA P t h (e1 «bop» e2, xs) (e1' «bop» e2, xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl BinOpRed1)

lemma BinOp_τred0r_xt2:
  "τred0r extTA P t h (e2, xs) (e2', xs')  τred0r extTA P t h (Val v «bop» e2, xs) (Val v «bop» e2', xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl BinOpRed2)

lemma LAss_τred0r:
  "τred0r extTA P t h (e, xs) (e', xs')  τred0r extTA P t h (V := e, xs) (V := e', xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl LAssRed)

lemma AAcc_τred0r_xt1:
  "τred0r extTA P t h (a, xs) (a', xs')  τred0r extTA P t h (ai, xs) (a'i, xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl AAccRed1)

lemma AAcc_τred0r_xt2:
  "τred0r extTA P t h (i, xs) (i', xs')  τred0r extTA P t h (Val ai, xs) (Val ai', xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl AAccRed2)

lemma AAss_τred0r_xt1:
  "τred0r extTA P t h (a, xs) (a', xs')  τred0r extTA P t h (ai := e, xs) (a'i := e, xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl AAssRed1)

lemma AAss_τred0r_xt2:
  "τred0r extTA P t h (i, xs) (i', xs')  τred0r extTA P t h (Val ai := e, xs) (Val ai' := e, xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl AAssRed2)

lemma AAss_τred0r_xt3:
  "τred0r extTA P t h (e, xs) (e', xs')  τred0r extTA P t h (Val aVal i := e, xs) (Val aVal i := e', xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl AAssRed3)

lemma ALength_τred0r_xt:
  "τred0r extTA P t h (a, xs) (a', xs')  τred0r extTA P t h (a∙length, xs) (a'∙length, xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl ALengthRed)

lemma FAcc_τred0r_xt:
  "τred0r extTA P t h (e, xs) (e', xs')  τred0r extTA P t h (eF{D}, xs) (e'F{D}, xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl FAccRed)

lemma FAss_τred0r_xt1:
  "τred0r extTA P t h (e, xs) (e', xs')  τred0r extTA P t h (eF{D} := e2, xs) (e'F{D} := e2, xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl FAssRed1)

lemma FAss_τred0r_xt2:
  "τred0r extTA P t h (e, xs) (e', xs')  τred0r extTA P t h (Val vF{D} := e, xs) (Val vF{D} := e', xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl FAssRed2)

lemma CAS_τred0r_xt1:
  "τred0r extTA P t h (e, xs) (e', xs')  τred0r extTA P t h (e∙compareAndSwap(DF, e2, e3), xs) (e'∙compareAndSwap(DF, e2, e3), xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl CASRed1)

lemma CAS_τred0r_xt2:
  "τred0r extTA P t h (e, xs) (e', xs')  τred0r extTA P t h (Val v∙compareAndSwap(DF, e, e3), xs) (Val v∙compareAndSwap(DF, e', e3), xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl CASRed2)

lemma CAS_τred0r_xt3:
  "τred0r extTA P t h (e, xs) (e', xs')  τred0r extTA P t h (Val v∙compareAndSwap(DF, Val v', e), xs) (Val v∙compareAndSwap(DF, Val v', e'), xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl CASRed3)

lemma Call_τred0r_obj:
  "τred0r extTA P t h (e, xs) (e', xs')  τred0r extTA P t h (eM(ps), xs) (e'M(ps), xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl CallObj)

lemma Call_τred0r_param:
  "τreds0r extTA P t h (es, xs) (es', xs')  τred0r extTA P t h (Val vM(es), xs) (Val vM(es'), xs')"
by(induct rule: rtranclp_induct2)(fastforce intro: rtranclp.rtrancl_into_rtrancl CallParams)+

lemma Block_τred0r_xt:
  "τred0r extTA P t h (e, xs(V := vo)) (e', xs')  τred0r extTA P t h ({V:T=vo; e}, xs) ({V:T=xs' V; e'}, xs'(V := xs V))"
proof(induct rule: rtranclp_induct2)
  case refl thus ?case by(simp del: fun_upd_apply)(auto simp add: fun_upd_apply)
next
  case (step e' xs' e'' xs'')
  from ‹τred0 extTA P t h (e', xs') (e'', xs'') 
  have "extTA,P,t  e',(h, xs') -ε e'',(h, xs'')" "τmove0 P h e'" "no_call P h e'" by auto
  hence "extTA,P,t  e',(h, xs'(V := xs V, V := xs' V)) -ε e'',(h, xs'')" by simp
  from BlockRed[OF this, of T] ‹τmove0 P h e' ‹no_call P h e'
  have "τred0 extTA P t h ({V:T=xs' V; e'}, xs'(V := xs V)) ({V:T=xs'' V; e''}, xs''(V := xs V))" by auto
  with ‹τred0r extTA P t h ({V:T=vo; e}, xs) ({V:T=xs' V; e'}, xs'(V := xs V)) show ?case ..
qed

lemma Sync_τred0r_xt:
  "τred0r extTA P t h (e, xs) (e', xs')  τred0r extTA P t h (syncV (e) e2, xs) (syncV (e') e2, xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl SynchronizedRed1)

lemma InSync_τred0r_xt:
  "τred0r extTA P t h (e, xs) (e', xs')  τred0r extTA P t h (insyncV (a) e, xs) (insyncV (a) e', xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl SynchronizedRed2)

lemma Seq_τred0r_xt:
  "τred0r extTA P t h (e, xs) (e', xs')  τred0r extTA P t h (e;;e2, xs) (e';;e2, xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl SeqRed)

lemma Cond_τred0r_xt:
  "τred0r extTA P t h (e, xs) (e', xs')  τred0r extTA P t h (if (e) e1 else e2, xs) (if (e') e1 else e2, xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl CondRed)

lemma Throw_τred0r_xt:
  "τred0r extTA P t h (e, xs) (e', xs')  τred0r extTA P t h (throw e, xs) (throw e', xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl ThrowRed)

lemma Try_τred0r_xt:
  "τred0r extTA P t h (e, xs) (e', xs')  τred0r extTA P t h (try e catch(C V) e2, xs) (try e' catch(C V) e2, xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl TryRed)

lemma τRed0_conv [iff]:
  "τRed0 P t h (e, es) (e', es') = (P,t ⊢0 e/es, h -ε e'/es', h  τMove0 P h (e, es))"
by(simp add: τRed0_def)

lemma τred0r_lcl_incr:
  "τred0r extTA P t h (e, xs) (e', xs')  dom xs  dom xs'"
by(induct rule: rtranclp_induct2)(auto dest: red_lcl_incr del: subsetI)

lemma τred0t_lcl_incr:
  "τred0t extTA P t h (e, xs) (e', xs')  dom xs  dom xs'"
by(rule τred0r_lcl_incr)(rule tranclp_into_rtranclp)

lemma τred0r_dom_lcl:
  assumes wwf: "wwf_J_prog P"
  shows "τred0r extTA P t h (e, xs) (e', xs')  dom xs'  dom xs  fv e"
apply(induct rule: converse_rtranclp_induct2)
 apply blast
apply(clarsimp del: subsetI)
apply(frule red_dom_lcl)
 apply(drule red_fv_subset[OF wwf])
apply auto
done

lemma τred0t_dom_lcl:
  assumes wwf: "wwf_J_prog P"
  shows "τred0t extTA P t h (e, xs) (e', xs')  dom xs'  dom xs  fv e"
by(rule τred0r_dom_lcl[OF wwf])(rule tranclp_into_rtranclp)

lemma τred0r_fv_subset:
  assumes wwf: "wwf_J_prog P"
  shows "τred0r extTA P t h (e, xs) (e', xs')  fv e'  fv e"
by(induct rule: converse_rtranclp_induct2)(auto dest: red_fv_subset[OF wwf])

lemma τred0t_fv_subset:
  assumes wwf: "wwf_J_prog P"
  shows "τred0t extTA P t h (e, xs) (e', xs')  fv e'  fv e"
by(rule τred0r_fv_subset[OF wwf])(rule tranclp_into_rtranclp)

lemma fixes e :: "('a, 'b, 'addr) exp" and es :: "('a, 'b, 'addr) exp list"
  shows τmove0_callD: "call e = (a, M, vs)  τmove0 P h e  (synthesized_call P h (a, M, vs)  τexternal' P h a M)"
  and τmoves0_callsD: "calls es = (a, M, vs)  τmoves0 P h es  (synthesized_call P h (a, M, vs)  τexternal' P h a M)"
apply(induct e and es rule: call.induct calls.induct)
apply(auto split: if_split_asm simp add: is_vals_conv)
apply(fastforce simp add: synthesized_call_def map_eq_append_conv τexternal'_def τexternal_def dest: sees_method_fun)+
done

lemma fixes e :: "('a, 'b, 'addr) exp" and es :: "('a, 'b, 'addr) exp list"
  shows τmove0_not_call: " τmove0 P h e; call e = (a, M, vs); synthesized_call P h (a, M, vs)   τexternal' P h a M"
  and τmoves0_not_calls: " τmoves0 P h es; calls es = (a, M, vs); synthesized_call P h (a, M, vs)   τexternal' P h a M"
apply(drule τmove0_callD[where P=P and h=h], simp)
apply(drule τmoves0_callsD[where P=P and h=h], simp)
done

lemma τred0_into_τRed0:
  assumes red: "τred0 (extTA2J0 P) P t h (e, Map.empty) (e', xs')"
  shows "τRed0 P t h (e, es) (e', es)"
proof -
  from red have red: "extTA2J0 P,P,t  e, (h, Map.empty) -ε e', (h, xs')"
    and "τmove0 P h e" and "no_call P h e" by auto
  hence "P,t ⊢0 e/es,h -ε e'/es,h"
    by-(erule red0Red,auto simp add: no_call_def)
  thus ?thesis using ‹τmove0 P h e by(auto)
qed

lemma τred0r_into_τRed0r:
  assumes wwf: "wwf_J_prog P"
  shows
  " τred0r (extTA2J0 P) P t h (e, Map.empty) (e'', Map.empty); fv e = {} 
   τRed0r P t h (e, es) (e'', es)"
proof(induct e xs"Map.empty :: 'addr locals" rule: converse_rtranclp_induct2)
  case refl show ?case by blast
next
  case (step e e' xs')
  from ‹τred0 (extTA2J0 P) P t h (e, Map.empty) (e', xs')
  have red: "extTA2J0 P,P,t  e, (h, Map.empty) -ε e', (h, xs')"
    and "τmove0 P h e"  and "no_call P h e" by auto
  from red_dom_lcl[OF red] ‹fv e = {} 
  have "dom xs' = {}" by(auto split:if_split_asm)
  hence "xs' = Map.empty" by(auto)
  moreover
  from wwf red have "fv e'  fv e" by(rule red_fv_subset)
  with ‹fv e = {} have "fv e' = {}" by blast
  ultimately have "τRed0r P t h (e', es) (e'', es)" by(rule step)
  moreover from red ‹τmove0 P h e xs' = Map.empty› ‹no_call P h e
  have "τRed0 P t h (e, es) (e', es)" by(auto simp add: no_call_def intro!: red0Red)
  ultimately show ?case by(blast intro: converse_rtranclp_into_rtranclp)
qed


lemma τred0t_into_τRed0t:
  assumes wwf: "wwf_J_prog P"
  shows
  " τred0t (extTA2J0 P) P t h (e, Map.empty) (e'', Map.empty); fv e = {} 
   τRed0t P t h (e, es) (e'', es)"
proof(induct e xs"Map.empty :: 'addr locals" rule: converse_tranclp_induct2)
  case base thus ?case
    by(blast intro!: tranclp.r_into_trancl τred0_into_τRed0)
next
  case (step e e' xs')
  from ‹τred0 (extTA2J0 P) P t h (e, Map.empty) (e', xs') 
  have red: "extTA2J0 P,P,t  e, (h, Map.empty) -ε e', (h, xs')" and "τmove0 P h e" and "no_call P h e" by auto
  from red_dom_lcl[OF red] ‹fv e = {}
  have "dom xs' = {}" by(auto split:if_split_asm)
  hence "xs' = Map.empty" by auto
  moreover from wwf red have "fv e'  fv e" by(rule red_fv_subset)
  with ‹fv e = {} have "fv e' = {}" by blast
  ultimately have "τRed0t P t h (e', es) (e'', es)" by(rule step)
  moreover from red ‹τmove0 P h e xs' = Map.empty› ‹no_call P h e
  have "τRed0 P t h (e, es) (e', es)" by(auto simp add: no_call_def intro!: red0Red)
  ultimately show ?case by(blast intro: tranclp_into_tranclp2)
qed

lemma τred0r_Val:
  "τred0r extTA P t h (Val v, xs) s'  s' = (Val v, xs)"
proof
  assume "τred0r extTA P t h (Val v, xs) s'"
  thus "s' = (Val v, xs)" by induct(auto)
qed auto

lemma τred0t_Val:
  "τred0t extTA P t h (Val v, xs) s'  False"
proof
  assume "τred0t extTA P t h (Val v, xs) s'"
  thus False by induct auto
qed auto

lemma τreds0r_map_Val:
  "τreds0r extTA P t h (map Val vs, xs) s'  s' = (map Val vs, xs)"
proof
  assume "τreds0r extTA P t h (map Val vs, xs) s'"
  thus "s' = (map Val vs, xs)" by induct auto
qed auto

lemma τreds0t_map_Val:
  "τreds0t extTA P t h (map Val vs, xs) s'  False"
proof
  assume "τreds0t extTA P t h (map Val vs, xs) s'"
  thus "False" by induct auto
qed auto

lemma Red_Suspend_is_call:
  " P,t ⊢0 e/exs, h -ta e'/exs', h'; Suspend w  set taw   is_call e'"
by(auto elim!: red0.cases dest: red_Suspend_is_call simp add: is_call_def)


lemma red0_mthr: "multithreaded final_expr0 (mred0 P)"
by(unfold_locales)(auto elim!: red0.cases dest: red_new_thread_heap)

lemma red0_τmthr_wf: "τmultithreaded_wf final_expr0 (mred0 P) (τMOVE0 P)"
proof -
  interpret multithreaded final_expr0 "mred0 P" by(rule red0_mthr)
  show ?thesis
  proof
    fix x1 m1 t ta1 x1' m1'
    assume "mred0 P t (x1, m1) ta1 (x1', m1')" "τMOVE0 P (x1, m1) ta1 (x1', m1')"
    thus "m1 = m1'" by(cases x1)(fastforce elim!: red0.cases dest: τmove0_heap_unchanged)
  qed(simp add: split_beta)
qed

lemma red_τmthr_wf: "τmultithreaded_wf final_expr (mred P) (τMOVE P)"
proof
  fix x1 m1 t ta1 x1' m1'
  assume "mred P t (x1, m1) ta1 (x1', m1')" "τMOVE P (x1, m1) ta1 (x1', m1')"
  thus "m1 = m1'" by(auto dest: τmove0_heap_unchanged simp add: split_def)
qed(simp add: split_beta)

end

sublocale J_heap_base < red_mthr: 
  τmultithreaded_wf 
    final_expr
    "mred P"
    convert_RA
    "τMOVE P"
  for P
by(rule red_τmthr_wf)

sublocale J_heap_base < red0_mthr:
  τmultithreaded_wf 
    final_expr0
    "mred0 P"
    convert_RA
    "τMOVE0 P"
  for P
by(rule red0_τmthr_wf)

context J_heap_base begin

lemma τRed0r_into_red0_τmthr_silent_moves:
  "τRed0r P t h (e, es) (e'', es'')  red0_mthr.silent_moves P t ((e, es), h) ((e'', es''), h)"
apply(induct rule: rtranclp_induct2)
 apply blast
apply(erule rtranclp.rtrancl_into_rtrancl)
apply(simp add: red0_mthr.silent_move_iff)
done

lemma τRed0t_into_red0_τmthr_silent_movet:
  "τRed0t P t h (e, es) (e'', es'')  red0_mthr.silent_movet P t ((e, es), h) ((e'', es''), h)"
apply(induct rule: tranclp_induct2)
apply(fastforce simp add: red0_mthr.silent_move_iff elim: tranclp.trancl_into_trancl)+
done

end

end

Theory J0Bisim

(*  Title:      JinjaThreads/Compiler/J0Bisim.thy
    Author:     Andreas Lochbihler
*)

section ‹Bisimulation proof for between source code small step semantics
  with and without callstacks for single threads›

theory J0Bisim imports
  J0
  "../J/JWellForm"
  "../Common/ExternalCallWF"
begin

inductive wf_state :: "'addr expr × 'addr expr list  bool"
  where
  " fvs (e # es) = {}; e  set es. is_call e 
    wf_state (e, es)"

inductive bisim_red_red0 :: "('addr expr × 'addr locals) × 'heap  ('addr expr × 'addr expr list) × 'heap  bool"
  where
  "wf_state ees  bisim_red_red0 ((collapse ees, Map.empty), h) (ees, h)"

abbreviation ta_bisim0 :: "('addr, 'thread_id, 'heap) J_thread_action  ('addr, 'thread_id, 'heap) J0_thread_action  bool"
where "ta_bisim0  ta_bisim (λt. bisim_red_red0)"

lemma wf_state_iff [simp, code]:
  "wf_state (e, es)  fvs (e # es) = {}  (e  set es. is_call e)"
by(simp add: wf_state.simps)

lemma bisim_red_red0I [intro]:
  " e' = collapse ees; xs = Map.empty; h' = h; wf_state ees   bisim_red_red0 ((e', xs), h') (ees, h)"
by(simp add: bisim_red_red0.simps del: split_paired_Ex)

lemma bisim_red_red0_final0D:
  " bisim_red_red0 (x1, m1) (x2, m2); final_expr0 x2   final_expr x1"
by(erule bisim_red_red0.cases) auto

context J_heap_base begin

lemma red0_preserves_wf_state:
  assumes wf: "wwf_J_prog P"
  and red: "P,t ⊢0 e / es, h -ta e' / es', h'"
  and wf_state: "wf_state (e, es)"
  shows "wf_state (e', es')"
using wf_state
proof(cases)
  assume "fvs (e # es) = {}" and icl: "e  set es. is_call e"
  hence fv: "fv e = {}" "fvs es = {}" by auto
  show ?thesis
  proof
    from red show "fvs (e' # es') = {}"
    proof cases
      case (red0Red xs')
      hence [simp]: "es' = es"
        and red: "extTA2J0 P,P,t  e,(h, Map.empty) -ta e',(h', xs')" by auto
      from red_fv_subset[OF wf red] fv have "fv e' = {}" by auto
      with fv show ?thesis by simp
    next
      case (red0Call a M vs U Ts T pns body D)
      hence [simp]: "ta = ε"
        "e' = blocks (this # pns) (Class D # Ts) (Addr a # vs) body"
        "es' = e # es" "h' = h"
        and sees: "P  class_type_of U sees M: TsT = (pns, body) in D" by auto
      from sees_wf_mdecl[OF wf sees]
      have "fv body  insert this (set pns)" "length Ts = length pns" by(simp_all add: wf_mdecl_def)
      thus ?thesis using fv ‹length vs = length pns by auto
    next
      case (red0Return E)
      with fv_inline_call[of e E] show ?thesis using fv by auto
    qed
  next
    from red icl show "eset es'. is_call e"
      by cases(simp_all add: is_call_def)
  qed
qed

lemma new_thread_bisim0_extNTA2J_extNTA2J0:
  assumes wf: "wwf_J_prog P"
  and red: "P,t  a'M'(vs), h -ta→ext va, h'"
  and nt: "NewThread t' CMa m  set tat"
  shows "bisim_red_red0 (extNTA2J P CMa, m) (extNTA2J0 P CMa, m)"
proof -
  obtain C M a where CMa [simp]: "CMa = (C, M, a)" by(cases CMa)
  from red nt have [simp]: "m = h'" by(rule red_ext_new_thread_heap)
  from red_external_new_thread_sees[OF wf red nt[unfolded CMa]]
  obtain T pns body D where h'a: "typeof_addr h' a = Class_type C"
    and sees: "P  C sees M: []T = (pns, body) in D" by auto
  from sees_wf_mdecl[OF wf sees] have "fv body  {this}" by(auto simp add: wf_mdecl_def)
  with red nt h'a sees show ?thesis by(fastforce simp add: is_call_def intro: bisim_red_red0.intros)
qed

lemma ta_bisim0_extNTA2J_extNTA2J0:
  " wwf_J_prog P; P,t  a'M'(vs), h -ta→ext va, h' 
   ta_bisim0 (extTA2J P ta) (extTA2J0 P ta)"
apply(auto simp add: ta_bisim_def intro!: list_all2_all_nthI)
apply(case_tac "tat ! n")
apply(simp_all)
apply(erule (1) new_thread_bisim0_extNTA2J_extNTA2J0)
apply(auto simp add: in_set_conv_nth)
done

lemma assumes wf: "wwf_J_prog P"
  shows red_red0_tabisim0:
  "P,t  e, s -ta e', s'  ta'. extTA2J0 P,P,t  e, s -ta' e', s'  ta_bisim0 ta ta'"
  and reds_reds0_tabisim0:
  "P,t  es, s [-ta→] es', s'  ta'. extTA2J0 P,P,t  es, s [-ta'→] es', s'  ta_bisim0 ta ta'"
proof(induct rule: red_reds.inducts)
  case (RedCallExternal s a T M Ts Tr D vs ta va h' ta' e' s')
  note red = P,t  aM(vs),hp s -ta→ext va,h'
  note T = typeof_addr (hp s) a = T
  from T P  class_type_of T sees M: TsTr = Native in D red
  have "extTA2J0 P,P,t  addr aM(map Val vs),s -extTA2J0 P ta e',(h', lcl s)"
    by(rule red_reds.RedCallExternal)(simp_all add: e' = extRet2J (addr aM(map Val vs)) va)
  moreover from ta' = extTA2J P ta T red wf
  have "ta_bisim0 ta' (extTA2J0 P ta)" by(auto intro: ta_bisim0_extNTA2J_extNTA2J0)
  ultimately show ?case unfolding s' = (h', lcl s) by blast
next
  case RedTryFail thus ?case by(force intro: red_reds.RedTryFail)
qed(fastforce intro: red_reds.intros simp add: ta_bisim_def ta_upd_simps)+

lemma assumes wf: "wwf_J_prog P"
  shows red0_red_tabisim0:
  "extTA2J0 P,P,t  e, s -ta e', s'  ta'. P,t  e, s -ta' e', s'  ta_bisim0 ta' ta"
  and reds0_reds_tabisim0:
  "extTA2J0 P,P,t  es, s [-ta→] es', s'  ta'. P,t  es, s [-ta'→] es', s'  ta_bisim0 ta' ta"
proof(induct rule: red_reds.inducts)
  case (RedCallExternal s a T M Ts Tr D vs ta va h' ta' e' s')
  note red = P,t  aM(vs),hp s -ta→ext va,h'
  note T = typeof_addr (hp s) a = T
  from T P  class_type_of T sees M: TsTr = Native in D red
  have "P,t  addr aM(map Val vs),s -extTA2J P ta e',(h', lcl s)"
    by(rule red_reds.RedCallExternal)(simp_all add: e' = extRet2J (addr aM(map Val vs)) va)
  moreover from ta' = extTA2J0 P ta T red wf
  have "ta_bisim0 (extTA2J P ta) ta'" by(auto intro: ta_bisim0_extNTA2J_extNTA2J0)
  ultimately show ?case unfolding s' = (h', lcl s) by blast
next
  case RedTryFail thus ?case by(force intro: red_reds.RedTryFail)
qed(fastforce intro: red_reds.intros simp add: ta_bisim_def ta_upd_simps)+

lemma red_inline_call_red:
  assumes red: "P,t  e, (h, Map.empty) -ta e', (h', Map.empty)"
  shows "call E = aMvs  P,t  inline_call e E, (h, x) -ta inline_call e' E, (h', x)"
  (is "_  ?concl E x")

  and
  "calls Es = aMvs  P,t  inline_calls e Es, (h, x) [-ta→] inline_calls e' Es, (h', x)"
  (is "_  ?concls Es x")
proof(induct E and Es arbitrary: x and x rule: call.induct calls.induct)
  case (Call obj M pns x)
  note IHobj = x. call obj = aMvs  ?concl obj x
  note IHpns = x. calls pns = aMvs  ?concls pns x
  obtain a M' vs where [simp]: "aMvs = (a, M', vs)" by(cases aMvs, auto)
  from ‹call (objM(pns)) = aMvs have "call (objM(pns)) = (a, M', vs)" by simp
  thus ?case
  proof(induct rule: call_callE)
    case CallObj
    with IHobj[of x] show ?case by(fastforce intro: red_reds.CallObj)
  next
    case (CallParams v'')
    with IHpns[of x] show ?case by(fastforce intro: red_reds.CallParams)
  next
    case Call
    from red_lcl_add[OF red, where ?l0.0=x]
    have "P,t  e,(h, x) -ta e', (h', x)" by simp
    with Call show ?case by(fastforce dest: BlockRed)
  qed
next
  case (Block V T' vo exp x)
  note IH = x. call exp = aMvs  ?concl exp x
  from IH[of "x(V := vo)"] ‹call {V:T'=vo; exp} = aMvs
  show ?case by(clarsimp simp del: fun_upd_apply)(drule BlockRed, auto)
next
  case (Cons_exp exp exps x)
  show ?case
  proof(cases "is_val exp")
    case True
    with ‹calls (exp # exps) = aMvs have "calls exps = aMvs" by auto
    with ‹calls exps = aMvs  ?concls exps x True
    show ?thesis by(fastforce intro: ListRed2)
  next
    case False
    with ‹calls (exp # exps) = aMvs have "call exp = aMvs" by auto
    with ‹call exp = aMvs  ?concl exp x
    show ?thesis by(fastforce intro: ListRed1)
  qed
qed(fastforce intro: red_reds.intros)+

lemma 
  assumes "P  class_type_of T sees M:UsU = (pns, body) in D" "length vs = length pns" "length Us = length pns"
  shows is_call_red_inline_call:
  " call e = (a, M, vs); typeof_addr (hp s) a = T  
   P,t  e, s -ε inline_call (blocks (this # pns) (Class D # Us) (Addr a # vs) body) e, s"
  (is "_  _  ?red e s")
  and is_calls_reds_inline_calls:
  " calls es = (a, M, vs); typeof_addr (hp s) a = T  
   P,t  es, s [-ε→] inline_calls (blocks (this # pns) (Class D # Us) (Addr a # vs) body) es, s"
  (is "_  _  ?reds es s")
proof(induct e and es arbitrary: s and s rule: call.induct calls.induct)
  case (Call obj M' params s)
  note IHObj = s. call obj = (a, M, vs); typeof_addr (hp s) a = T   ?red obj s
  note IHParams = s.  calls params = (a, M, vs); typeof_addr (hp s) a = T   ?reds params s
  from ‹call (objM'(params)) = (a, M, vs)
  show ?case
  proof(induct rule: call_callE)
    case CallObj
    from IHObj[OF CallObj] typeof_addr (hp s) a = T have "?red obj s" by blast
    moreover from CallObj have "¬ is_val obj" by auto
    ultimately show ?case by(auto intro: red_reds.CallObj)
  next
    case (CallParams v)
    from IHParams[OF ‹calls params = (a, M, vs)] typeof_addr (hp s) a = T
    have "?reds params s" by blast
    moreover from CallParams have "¬ is_vals params" by auto
    ultimately show ?case using obj = Val v by(auto intro: red_reds.CallParams)
  next
    case Call
    with RedCall[where s=s, simplified, OF typeof_addr (hp s) a = T P  class_type_of T sees M:UsU = (pns, body) in D ‹length vs = length pns ‹length Us = length pns] 
    show ?thesis by(simp)
  qed
next
  case (Block V ty vo exp s)
  note IH = s. call exp = (a, M, vs); typeof_addr (hp s) a = T   ?red exp s
  from ‹call {V:ty=vo; exp} = (a, M, vs) IH[of "(hp s, (lcl s)(V := vo))"] typeof_addr (hp s) a = T
  show ?case by(cases s, simp del: fun_upd_apply)(drule red_reds.BlockRed, simp)
qed(fastforce intro: red_reds.intros)+

lemma red_inline_call_red':
  assumes fv: "fv ee = {}"
  and eefin: "¬ final ee"
  shows " call E = aMvs; P,t  inline_call ee E, (h, x) -ta E', (h', x')  
          ee'. E' = inline_call ee' E  P,t  ee, (h, Map.empty) -ta ee', (h', Map.empty)  x = x'"
  (is " _; _   ?concl E E' x x'")
  and   " calls Es = aMvs; P,t  inline_calls ee Es, (h, x) [-ta→] Es', (h', x')  
          ee'. Es' = inline_calls ee' Es  P,t  ee, (h, Map.empty) -ta ee', (h', Map.empty)  x = x'"
  (is " _; _   ?concls Es Es' x x'")
proof(induct E and Es arbitrary: E' x x' and Es' x x' rule: call.induct calls.induct)
  case new thus ?case by simp
next
  case (newArray T exp E' x x')
  thus ?case using eefin by(auto elim!: red_cases)
next
  case Cast thus ?case using eefin by(auto elim!:red_cases) 
next
  case InstanceOf thus ?case using eefin by(auto elim!:red_cases) 
next
  case Val thus ?case by simp
next
  case Var thus ?case by simp
next
  case LAss
  thus ?case using eefin by(auto elim!: red_cases)
next
  case BinOp
  thus ?case using eefin by(auto elim!: red_cases split: if_split_asm)
next
  case AAcc
  thus ?case using eefin by(auto elim!: red_cases split: if_split_asm)
next
  case AAss thus ?case using eefin by(auto elim!: red_cases split: if_split_asm)
next
  case ALen thus ?case using eefin by(auto elim!: red_cases split: if_split_asm)
next
  case FAcc thus ?case using eefin by(auto elim!: red_cases)
next
  case FAss thus ?case using eefin by(auto elim!: red_cases split: if_split_asm)
next
  case CompareAndSwap thus ?case using eefin by(auto elim!: red_cases split: if_split_asm)
next
  case (Call obj M pns E' x x')
  note IHobj = x E' x'. call obj = aMvs; P,t  inline_call ee obj,(h, x) -ta E',(h', x')
                 ?concl obj E' x x'
  note IHpns = Es' x x'. calls pns = aMvs; P,t  inline_calls ee pns,(h, x) [-ta→] Es',(h', x')
                ?concls pns Es' x x'
  note red = P,t  inline_call ee (objM(pns)),(h, x) -ta  E',(h', x')
  obtain a M' vs where [simp]: "aMvs = (a, M', vs)" by(cases aMvs, auto)
  from ‹call (objM(pns)) = aMvs have "call (objM(pns)) = (a,M',vs)" by simp
  thus ?case
  proof(cases rule: call_callE)
    case CallObj
    hence "¬ is_val obj" by auto
    with red CallObj eefin obtain obj' where "E' = obj'M(pns)" 
      and red': "P,t  inline_call ee obj,(h, x) -ta obj',(h', x')"
      by(auto elim!: red_cases)
    from IHobj[OF _ red'] CallObj obtain ee' 
      where "inline_call ee' obj = obj'" "x = x'"
      and "P,t  ee,(h, Map.empty) -ta ee',(h', Map.empty)" by(auto simp del: fun_upd_apply)
    with E' = obj'M(pns) CallObj red' show ?thesis by(fastforce simp del: fun_upd_apply)
  next
    case (CallParams v'')
    hence "¬ is_vals pns" by auto
    with red CallParams eefin obtain pns' where "E' = objM(pns')" 
      and red': "P,t  inline_calls ee pns,(h, x) [-ta→] pns',(h', x')"
      by(auto elim!: red_cases)
    from IHpns[OF _ red'] CallParams obtain ee' 
      where "inline_calls ee' pns = pns'" "x = x'"
      and "P,t  ee,(h, Map.empty) -ta ee',(h', Map.empty)"
      by(auto simp del: fun_upd_apply)
    with E' = objM(pns') CallParams red' ¬ is_vals pns
    show ?thesis by(auto simp del: fun_upd_apply)
  next
    case Call
    with red have red': "P,t  ee,(h, x) -ta E',(h', x')" by(auto)
    from red_lcl_sub[OF red', of "{}"] fv
    have "P,t  ee,(h, Map.empty) -ta E',(h', Map.empty)" by simp
    moreover have "x' = x"
    proof(rule ext)
      fix V
      from red_notfree_unchanged[OF red', of V] fv
      show "x' V = x V" by simp
    qed
    ultimately show ?thesis using Call by simp
  qed
next
  case (Block V ty voo exp E' x x')
  note IH = x E' x'. call exp = aMvs; P,t  inline_call ee exp,(h, x) -ta E',(h', x')
             ?concl exp E' x x'
  from ‹call {V:ty=voo; exp} = aMvs have ic: "call exp = aMvs" by simp
  note red = P,t  inline_call ee {V:ty=voo; exp},(h, x) -ta E',(h', x')
  hence "P,t  {V:ty=voo; inline_call ee exp},(h, x) -ta E',(h', x')" by simp
  with ic eefin obtain exp' x'' where "E' = {V:ty=x'' V; exp'}"
    and red': "P,t  inline_call ee exp,(h, fun_upd x V voo) -ta exp',(h', x'')"
    and "x' = fun_upd x'' V (x V)"
    by -(erule red.cases,auto dest: inline_call_eq_Val)
  from IH[OF ic red'] obtain ee' vo' 
    where icl: "inline_call ee' exp = exp'" "x'' = fun_upd x V voo"
    and red'': "P,t  ee,(h, Map.empty) -ta ee',(h', Map.empty)" by blast
  from x'' = fun_upd x V voo have "x'' V = voo" by(simp add: fun_eq_iff)
  with icl red'' E' = {V:ty=x'' V; exp'} x' = fun_upd x'' V (x V) red'
  show ?case by(auto simp del: fun_upd_apply)
next
  case Synchronized thus ?case using eefin by(auto elim!: red_cases)
next
  case InSynchronized thus ?case using eefin by(auto elim!: red_cases)
next
  case Seq 
  thus ?case using eefin by(auto elim!: red_cases)
next
  case Cond thus ?case using eefin by(auto elim!: red_cases)
next
  case While thus ?case by simp
next
  case throw
  thus ?case using eefin by(auto elim!: red_cases)
next
  case TryCatch
  thus ?case using eefin by(auto elim!: red_cases)
next
  case Nil_exp thus ?case by simp
next
  case Cons_exp
  thus ?case using eefin by(auto elim!: reds_cases split: if_split_asm)
qed

lemma assumes sees: "P  class_type_of T sees M:UsU = (pns, body) in D"
  shows is_call_red_inline_callD:
  " P,t  e, s -ta e', s'; call e = (a, M, vs); typeof_addr (hp s) a = T 
   e' = inline_call (blocks (this # pns) (Class D # Us) (Addr a # vs) body) e"
  and is_calls_reds_inline_callsD:
  " P,t  es, s [-ta→] es', s'; calls es = (a, M, vs); typeof_addr (hp s) a = T 
   es' = inline_calls (blocks (this # pns) (Class D # Us) (Addr a # vs) body) es"
proof(induct rule: red_reds.inducts)
  case RedCall with sees show ?case by(auto dest: sees_method_fun)
next
  case RedCallExternal
  with sees show ?case by(auto dest: sees_method_fun)
next
  case (BlockRed e h x V vo ta e' h' x' T')
  from ‹call {V:T'=vo; e} = (a, M, vs) typeof_addr (hp (h, x)) a = T sees
  have "call e = (a, M, vs)" and "¬ synthesized_call P h (a, M, vs)"
    by(auto simp add: synthesized_call_conv dest: sees_method_fun)
  with P,t  e,(h, x(V := vo)) -ta e',(h', x')
  have "x(V := vo) = x'" by(auto dest: is_call_red_state_unchanged)
  hence "x' V = vo" by auto
  with BlockRed show ?case by(simp)
qed(fastforce split: if_split_asm)+

lemma (in -) wf_state_ConsD: "wf_state (e, e' # es)  wf_state (e', es)"
by(simp)

lemma red_fold_exs:
  " P,t  e,(h, Map.empty) -ta e',(h', Map.empty); wf_state (e, es) 
    P,t  collapse (e, es), (h, Map.empty) -ta collapse (e', es), (h', Map.empty)"
  (is " _; _   ?concl e e' es")
proof(induction es arbitrary: e e')
  case Nil thus ?case by simp
next
  case (Cons E es)
  note wf = ‹wf_state (e, E # es)
  note red = P,t  e,(h, Map.empty) -ta e',(h', Map.empty)
  from wf obtain a M vs arrobj where call: "call E = (a, M, vs)" 
    by(auto simp add: is_call_def)
  from red call have "P,t  inline_call e E,(h, Map.empty) -ta inline_call e' E,(h', Map.empty)"
    by(rule red_inline_call_red)
  hence "P,t  collapse (inline_call e E, es),(h, Map.empty) -ta  collapse (inline_call e' E, es),(h', Map.empty)"
  proof(rule Cons.IH)
    from wf have "fv E = {}" "fv e = {}" by auto
    with fv_inline_call[of e E] have "fv (inline_call e E) = {}" by auto
    thus "wf_state (inline_call e E, es)" using wf by auto
  qed
  thus ?case by simp
qed

lemma red_fold_exs':
  " P,t  collapse (e, es), (h, Map.empty) -ta e', (h', x'); wf_state (e, es); ¬ final e 
   E'. e' = collapse (E', es)  P,t  e, (h, Map.empty) -ta E', (h', Map.empty)"
  (is " _; _; _   ?concl e es")
proof(induction es arbitrary: e)
  case Nil
  hence red': "P,t  e,(h, Map.empty) -ta e',(h', x')" by simp
  with red_dom_lcl[OF this] ‹wf_state (e, []) show ?case by auto
next
  case (Cons E es)
  note wf = ‹wf_state (e, E # es)
  note nfin = ¬ final e
  from wf have "fv e = {}" by simp
  from wf obtain a M vs where call: "call E = (a, M, vs)" by(auto simp add: is_call_def)
  from P,t  collapse (e, E # es),(h, Map.empty) -ta e',(h', x')
  have "P,t  collapse (inline_call e E, es),(h, Map.empty) -ta e',(h', x')" by simp
  moreover from wf fv_inline_call[of e E] have "wf_state (inline_call e E, es)" by auto
  moreover from nfin call have "¬ final (inline_call e E)" by(auto elim!: final.cases)
  ultimately have "?concl (inline_call e E) es" by(rule Cons.IH)
  then obtain E' where e': "e' = collapse (E', es)" 
    and red': "P,t  inline_call e E,(h, Map.empty) -ta E',(h', Map.empty)" by blast
  from red_inline_call_red'(1)[OF ‹fv e = {} nfin ‹call E = (a, M, vs) red']
  obtain e' where "E' = inline_call e' E" "P,t  e,(h, Map.empty) -ta e',(h', Map.empty)" by auto
  thus ?case using e' by auto
qed

lemma τRed0r_inline_call_not_final:
  "e' es'. τRed0r P t h (e, es) (e', es')  (final e'  es' = [])  collapse (e, es) = collapse (e', es')"
proof(induct es arbitrary: e)
  case Nil thus ?case by blast
next
  case (Cons e es E) show ?case
  proof(cases "final E")
    case True
    hence "τRed0 P t h (E, e # es) (inline_call E e, es)" by(auto intro: red0Return)
    moreover from Cons[of "inline_call E e"] obtain e' es'
      where "τRed0r P t h (inline_call E e, es) (e', es')" "final e'  es' = []"
      "collapse (inline_call E e, es) = collapse (e', es')" by blast
    ultimately show ?thesis unfolding collapse.simps by(blast intro: converse_rtranclp_into_rtranclp)
  qed blast
qed

lemma τRed0_preserves_wf_state:
  " wwf_J_prog P; τRed0 P t h (e, es) (e', es'); wf_state (e, es)   wf_state (e', es')"
by(auto simp del: wf_state_iff intro: red0_preserves_wf_state)

lemma τRed0r_preserves_wf_state:
  assumes wf: "wwf_J_prog P"
  shows " τRed0r P t h (e, es) (e', es'); wf_state (e, es)   wf_state (e', es')"
by(induct rule: rtranclp_induct2)(blast intro: τRed0_preserves_wf_state[OF wf])+

lemma τRed0t_preserves_wf_state:
  assumes wf: "wwf_J_prog P"
  shows " τRed0t P t h (e, es) (e', es'); wf_state (e, es)   wf_state (e', es')"
by(induct rule: tranclp_induct2)(blast intro: τRed0_preserves_wf_state[OF wf])+

lemma collapse_τmove0_inv:
  " eset es. is_call e; ¬ final e   τmove0 P h (collapse (e, es)) = τmove0 P h e"
proof(induction es arbitrary: e)
  case Nil thus ?case by clarsimp
next
  case (Cons e es e'')
  from aset (e # es). is_call a obtain aMvs where calls: "eset es. is_call e"
    and call: "call e = aMvs" by(auto simp add: is_call_def)
  note calls moreover
  from ¬ final e'' call have "¬ final (inline_call e'' e)" by(auto simp add: final_iff)
  ultimately have "τmove0 P h (collapse (inline_call e'' e, es)) = τmove0 P h (inline_call e'' e)"
    by(rule Cons.IH)
  also from call ¬ final e'' have " = τmove0 P h e''" by(auto simp add: inline_call_τmove0_inv)
  finally show ?case by simp
qed

lemma τRed0r_into_silent_moves:
  "τRed0r P t h (e, es) (e', es')  red0_mthr.silent_moves P t ((e, es), h) ((e', es'), h)"
by(induct rule: rtranclp_induct2)(fastforce intro: τtrsys.silent_move.intros elim!: rtranclp.rtrancl_into_rtrancl)+

lemma τRed0t_into_silent_movet:
  "τRed0t P t h (e, es) (e', es')  red0_mthr.silent_movet P t ((e, es), h) ((e', es'), h)"
by(induct rule: tranclp_induct2)(fastforce intro: τtrsys.silent_move.intros elim!: tranclp.trancl_into_trancl)+

lemma red_simulates_red0:
  assumes wwf: "wwf_J_prog P"
  and sim: "bisim_red_red0 s1 s2" "mred0 P t s2 ta2 s2'" "¬ τMOVE0 P s2 ta2 s2'"
  shows "s1' ta1. mred P t s1 ta1 s1'  ¬ τMOVE P s1 ta1 s1'  bisim_red_red0 s1' s2'  ta_bisim0 ta1 ta2"
proof -
  note sim
  moreover obtain e1 h1 x1 where s1: "s1 = ((e1, x1), h1)" by(cases s1, auto)
  moreover obtain e' es' h2' where s2': "s2' = ((e', es'), h2')" by(cases s2', auto)
  moreover obtain e es h2 where s2: "s2 = ((e, es), h2)" by(cases s2, auto)
  ultimately have bisim: "bisim_red_red0 ((e1, x1), h1) ((e, es), h2)"
    and red: "P,t ⊢0 e/es, h2 -ta2 e'/es', h2'" 
    and τ: "¬ τmove0 P h2 e  ¬ final e  ta2  ε" by auto
  from red τ have τ: "¬ τmove0 P h2 e" and nfin: "¬ final e"
    by(cases, auto dest: red_τ_taD[where extTA="extTA2J0 P", OF extTA2J0_ε])+
  from bisim have heap: "h1 = h2" and fold: "e1 = collapse (e, es)"
    and x1: "x1 = Map.empty" and wf_state: "wf_state (e, es)"
    by(auto elim!: bisim_red_red0.cases)
  from red wf_state have wf_state': "wf_state (e', es')" by(rule red0_preserves_wf_state[OF wwf])
  from red show ?thesis
  proof(cases)
    case (red0Red xs')
    hence [simp]: "es' = es"
      and "extTA2J0 P,P,t  e, (h2, Map.empty) -ta2 e', (h2', xs')" by auto
    from red0_red_tabisim0[OF wwf this(2)] obtain ta1
      where red': "P,t  e,(h2, Map.empty) -ta1 e',(h2', xs')"
      and tasim: "ta_bisim0 ta1 ta2" by auto
    moreover from wf_state have "fv e = {}" by auto
    with red_dom_lcl[OF red'] red_fv_subset[OF wwf red'] have "xs' = Map.empty" by auto
    ultimately have "P,t  e,(h2, Map.empty) -ta1 e',(h2', Map.empty)" by simp
    with wf_state have "P,t  collapse (e, es),(h2, Map.empty) -ta1 collapse (e', es),(h2', Map.empty)"
      by -(erule red_fold_exs, auto)
    moreover from τ wf_state fold nfin have "¬ τmove0 P h2 e1" by(auto simp add: collapse_τmove0_inv)
    hence "¬ τMOVE P ((collapse (e, es), Map.empty), h2) ta1 ((collapse (e', es), Map.empty), h2')"
      unfolding fold by auto
    moreover from wf_state' have "bisim_red_red0 ((collapse (e', es), Map.empty), h2') s2'" 
      unfolding s2' by(auto)
    ultimately show ?thesis unfolding heap s1 s2 s2' fold x1
      using tasim by(fastforce intro!: exI rtranclp.rtrancl_refl)
  next
    case red0Call
    with τ have False
      by(auto simp add: synthesized_call_def τexternal'_def dest!: τmove0_callD[where P=P and h=h2] dest: sees_method_fun)
    thus ?thesis ..
  next
    case red0Return with nfin show ?thesis by simp
  qed
qed

lemma delay_bisimulation_measure_red_red0:
  assumes wf: "wwf_J_prog P"
  shows "delay_bisimulation_measure (mred P t) (mred0 P t) bisim_red_red0 ta_bisim0 (τMOVE P) (τMOVE0 P) (λe e'. False) (λ((e, es), h) ((e, es'), h). length es < length es')"
proof
  show "wfP (λe e'. False)" by auto
next
  have "wf {(x :: nat, y). x < y}" by(rule wf_less)
  hence "wf (inv_image {(x :: nat, y). x < y} (length o snd o fst))" by(rule wf_inv_image)
  also have "inv_image {(x :: nat, y). x < y} (length o snd o fst) = {(x, y). (λ((e, es), h) ((e, es'), h). length es < length es') x y}" by auto
  finally show "wfP (λ((e, es), h) ((e, es'), h). length es < length es')"
    unfolding wfP_def .
next
  fix s1 s2 s1'
  assume "bisim_red_red0 s1 s2" and "red_mthr.silent_move P t s1 s1'"
  moreover obtain e1 h1 x1 where s1: "s1 = ((e1, x1), h1)" by(cases s1, auto)
  moreover obtain e1' h1' x1' where s1': "s1' = ((e1', x1'), h1')" by(cases s1', auto)
  moreover obtain e es h2 where s2: "s2 = ((e, es), h2)" by(cases s2, auto)
  ultimately have bisim: "bisim_red_red0 ((e1, x1), h1) ((e, es), h2)"
    and red: "P,t  e1, (h1, x1) -ε e1', (h1', x1')" 
    and τ: "τmove0 P h1 e1" by(auto elim: τtrsys.silent_move.cases)
  from bisim have heap: "h1 = h2"
    and fold: "e1 = collapse (e, es)"
    and x1: "x1 = Map.empty"
    and wf_state: "wf_state (e, es)"
    by(auto elim!: bisim_red_red0.cases)
  from τRed0r_inline_call_not_final[of P t h1 e es]
  obtain e' es' where red1: "τRed0r P t h1 (e, es) (e', es')"
    and "final e'  es' = []" 
    and feq: "collapse (e, es) = collapse (e', es')" by blast
  have nfin: "¬ final e'"
  proof
    assume fin: "final e'"
    hence "es' = []" by(rule ‹final e'  es' = [])
    with fold fin feq have "final e1" by simp
    with red show False by auto
  qed
  from red1 wf_state have wf_state': "wf_state (e', es')" by(rule τRed0r_preserves_wf_state[OF wf])
  hence fv: "fvs (e' # es') = {}" and icl: "eset es'. is_call e" by auto
  from red_fold_exs'[OF red[unfolded fold x1 feq] wf_state' nfin]
  obtain E' where e1': "e1' = collapse (E', es')" 
    and red': "P,t  e',(h1, Map.empty) -ε E',(h1', Map.empty)" by auto
  from fv fv_collapse[of es e] wf_state fold feq have "fv e1 = {}" by(auto)
  with red_dom_lcl[OF red] x1 have x1': "x1' = Map.empty" by simp
  from red_red0_tabisim0[OF wf red']
  have red'': "extTA2J0 P,P,t  e',(h1, Map.empty) -ε E',(h1', Map.empty)" by simp
  show "bisim_red_red0 s1' s2  (λe e'. False)^++ s1' s1 
        (s2'. red0_mthr.silent_movet P t s2 s2'  bisim_red_red0 s1' s2')"
  proof(cases "no_call P h1 e'")
    case True
    with red'' have "P,t ⊢0 e'/es', h1 -ε E'/es', h1'" unfolding no_call_def by(rule red0Red)
    moreover from red τ have [simp]: "h1' = h1" by(auto dest: τmove0_heap_unchanged)
    moreover from τ fold feq icl nfin have "τmove0 P h1 e'" by(simp add: collapse_τmove0_inv)
    ultimately have "τRed0 P t h1 (e', es') (E', es')" using ‹τmove0 P h1 e' by auto
    with red1 have "τRed0t P t h1 (e, es) (E', es')" by(rule rtranclp_into_tranclp1)
    moreover hence "wf_state (E', es')" using wf_state by(rule τRed0t_preserves_wf_state[OF wf])
    hence "bisim_red_red0 ((e1', x1'), h1) ((E', es'), h1)" unfolding x1' e1' by(auto)
    ultimately show ?thesis using s1 s1' s2 heap by simp(blast intro:  τRed0t_into_silent_movet)
  next
    case False
    then obtain a M vs where call: "call e' = (a, M, vs)"
      and notsynth: "¬ synthesized_call P h1 (a, M, vs)" by(auto simp add: no_call_def)
    from notsynth called_methodD[OF red'' call] obtain T D Us U pns body
      where "h1' = h1"
      and ha: "typeof_addr h1 a = T"
      and sees: "P  class_type_of T sees M: UsU = (pns, body) in D"
      and length: "length vs = length pns" "length Us = length pns"
      by(auto)
    let ?e = "blocks (this # pns) (Class D # Us) (Addr a # vs) body"
    from call ha have "P,t ⊢0 e'/es',h1 -ε ?e/e' # es',h1"
      using sees length by(rule red0Call)
    moreover from τ fold feq icl nfin False have "τmove0 P h1 e'" by(simp add: collapse_τmove0_inv)
    ultimately have "τRed0 P t h1 (e', es') (?e, e' # es')" by auto
    with red1 have "τRed0t P t h1 (e, es) (?e, e' # es')" by(rule rtranclp_into_tranclp1)
    moreover {
      from P,t ⊢0 e'/es',h1 -ε ?e/e' # es',h1 have "wf_state (?e, e' # es')"
        using wf_state' by(rule red0_preserves_wf_state[OF wf])
      moreover from is_call_red_inline_callD[OF sees red' call] ha
      have "E' = inline_call ?e e'" by auto
      ultimately have "bisim_red_red0 s1' ((?e, e' # es'), h1')" unfolding s1' e1' x1'
        by(auto del: wf_state.cases wf_state.intros) }
    moreover from red' call notsynth have "h1 = h1'"
      by(auto dest: is_call_red_state_unchanged)
    ultimately show ?thesis unfolding heap x1' x1 s2 s1' h1' = h1
      by(blast intro: τRed0t_into_silent_movet)
  qed
next
  fix s1 s2 s2'
  assume "bisim_red_red0 s1 s2" and "red0_mthr.silent_move P t s2 s2'"
  moreover obtain e1 h1 x1 where s1: "s1 = ((e1, x1), h1)" by(cases s1, auto)
  moreover obtain e' es' h2' where s2': "s2' = ((e', es'), h2')" by(cases s2', auto)
  moreover obtain e es h2 where s2: "s2 = ((e, es), h2)" by(cases s2, auto)
  ultimately have bisim: "bisim_red_red0 ((e1, x1), h1) ((e, es), h2)"
    and red: "P,t ⊢0 e/es, h2 -ε e'/es', h2'" 
    and τ: "τmove0 P h2 e  final e" by(auto elim: τtrsys.silent_move.cases)
  from bisim have heap: "h1 = h2"
    and fold: "e1 = collapse (e, es)"
    and x1: "x1 = Map.empty" and wf_state: "wf_state (e, es)"
    by(auto elim!: bisim_red_red0.cases)
  from red wf_state have wf_state': "wf_state (e', es')" by(rule red0_preserves_wf_state[OF wf])
  from red show "bisim_red_red0 s1 s2'  (λ((e, es), h) ((e, es'), h). length es < length es')++ s2' s2 
        (s1'. red_mthr.silent_movet P t s1 s1'  bisim_red_red0 s1' s2')"
  proof cases
    case (red0Red xs')
    hence [simp]: "es' = es"
      and "extTA2J0 P,P,t  e, (h2, Map.empty) -ε e', (h2', xs')" by auto
    from red0_red_tabisim0[OF wf this(2)] have red': "P,t  e,(h2, Map.empty) -ε e',(h2', xs')" by auto
    moreover from wf_state have "fv e = {}" by auto
    with red_dom_lcl[OF red'] red_fv_subset[OF wf red'] have "xs' = Map.empty" by auto
    ultimately have "P,t  e,(h2, Map.empty) -ε e',(h2', Map.empty)" by simp
    hence "P,t  collapse (e, es),(h2, Map.empty) -ε collapse (e', es),(h2', Map.empty)" 
      using wf_state by(rule red_fold_exs)
    moreover from red' have "¬ final e" by auto
    with τ wf_state fold have "τmove0 P h2 e1" by(auto simp add: collapse_τmove0_inv)
    ultimately have "red_mthr.silent_movet P t s1 ((collapse (e', es), Map.empty), h2')"
      using s1 fold τ x1 heap by(auto intro: τtrsys.silent_move.intros)
    moreover from wf_state' have "bisim_red_red0 ((collapse (e', es), Map.empty), h2') s2'"
      unfolding s2' by(auto)
    ultimately show ?thesis by blast
  next
    case (red0Call a M vs U Ts T pns body D)
    hence [simp]: "es' = e # es" "h2' = h2" "e' = blocks (this # pns) (Class D # Ts) (Addr a # vs) body"
      and call: "call e = (a, M, vs)"
      and ha: "typeof_addr h2 a = U"
      and sees: "P  class_type_of U sees M: TsT = (pns, body) in D"
      and len: "length vs = length pns" "length Ts = length pns" by auto
    from is_call_red_inline_call(1)[OF sees len call, of "(h2, Map.empty)"] ha
    have "P,t  e,(h2, Map.empty) -ε inline_call e' e, (h2, Map.empty)" by simp
    hence "P,t  collapse (e, es), (h2, Map.empty) -ε collapse (inline_call e' e, es), (h2, Map.empty)"
      using wf_state by(rule red_fold_exs)
    moreover from call ha wf_state τ have "τmove0 P h2 (collapse (e, es))"
      by(subst collapse_τmove0_inv) auto
    hence "τMOVE P ((collapse (e, es), Map.empty), h2) ε ((collapse (inline_call e' e, es), Map.empty), h2)" by auto
    moreover from wf_state'
    have "bisim_red_red0 ((collapse (inline_call e' e, es), Map.empty), h2) ((e', es'), h2')"
      by(auto)
    ultimately show ?thesis unfolding s1 s2 s2' fold heap x1 by(fastforce)
  next
    case (red0Return E)
    hence [simp]: "es = E # es'" "e' = inline_call e E" "h2' = h2" by auto
    from fold wf_state'
    have "bisim_red_red0 ((e1, Map.empty), h1) ((inline_call e E, es'), h2)"
      unfolding heap by(auto)
    thus ?thesis using s1 s2' s2 x1 by auto
  qed
next
  fix s1 s2 ta1 s1'
  assume "bisim_red_red0 s1 s2" and "mred P t s1 ta1 s1'" and "¬ τMOVE P s1 ta1 s1'"
  moreover obtain e1 h1 x1 where s1: "s1 = ((e1, x1), h1)" by(cases s1, auto)
  moreover obtain e1' h1' x1' where s1': "s1' = ((e1', x1'), h1')" by(cases s1', auto)
  moreover obtain e es h2 where s2: "s2 = ((e, es), h2)" by(cases s2, auto)
  ultimately have bisim: "bisim_red_red0 ((e1, x1), h1) ((e, es), h2)"
    and red: "P,t  e1, (h1, x1) -ta1 e1', (h1', x1')" 
    and τ: "¬ τmove0 P h1 e1" by(auto dest: red_τ_taD[where extTA="extTA2J P", OF extTA2J_ε])
  from bisim have heap: "h1 = h2"
    and fold: "e1 = collapse (e, es)"
    and x1: "x1 = Map.empty"
    and wf_state: "wf_state (e, es)"
    by(auto elim!: bisim_red_red0.cases)
  from τRed0r_inline_call_not_final[of P t h1 e es]
  obtain e' es' where red1: "τRed0r P t h1 (e, es) (e', es')"
    and "final e'  es' = []" and feq: "collapse (e, es) = collapse (e', es')" by blast
  hence red1': "red0_mthr.silent_moves P t ((e, es), h2) ((e', es'), h2)"
    unfolding heap by -(rule τRed0r_into_silent_moves)
  have nfin: "¬ final e'"
  proof
    assume fin: "final e'"
    hence "es' = []" by(rule ‹final e'  es' = [])
    with fold fin feq have "final e1" by simp
    with red show False by auto
  qed
  from red1 wf_state have wf_state': "wf_state (e', es')" by(rule τRed0r_preserves_wf_state[OF wf])
  hence fv: "fvs (e' # es') = {}" and icl: "e  set es'. is_call e" by auto
  from red_fold_exs'[OF red[unfolded fold x1 feq] wf_state' nfin]
  obtain E' where e1': "e1' = collapse (E', es')" 
    and red': "P,t  e',(h1, Map.empty) -ta1 E',(h1', Map.empty)" by auto
  from fv fv_collapse[OF icl, of e'] fold feq have "fv e1 = {}" by(auto)
  with red_dom_lcl[OF red] x1 have x1': "x1' = Map.empty" by simp
  from red_red0_tabisim0[OF wf red'] obtain ta2
    where red'': "extTA2J0 P,P,t  e',(h1, Map.empty) -ta2 E',(h1', Map.empty)"
    and tasim: "ta_bisim0 ta1 ta2" by auto
  from τ fold feq icl nfin have "¬ τmove0 P h1 e'" by(simp add: collapse_τmove0_inv)
  hence "aMvs. call e' = aMvs  synthesized_call P h1 aMvs"
    by(auto dest: τmove0_callD)
  with red'' have red''': "P,t ⊢0 e'/es', h1 -ta2 E'/es', h1'" by(rule red0Red)
  moreover from τ fold feq icl nfin have "¬ τmove0 P h1 e'" by(simp add: collapse_τmove0_inv)
  hence "¬ τMOVE0 P ((e', es'), h1) ta2 ((E', es'), h1')" using nfin by auto
  moreover from red''' wf_state' have "wf_state (E', es')" by(rule red0_preserves_wf_state[OF wf])
  hence "bisim_red_red0 s1' ((E', es'), h1')" unfolding s1' e1' x1' by(auto)
  ultimately show "s2' s2'' ta2. red0_mthr.silent_moves P t s2 s2'  mred0 P t s2' ta2 s2'' 
                       ¬ τMOVE0 P s2' ta2 s2''  bisim_red_red0 s1' s2''  ta_bisim0 ta1 ta2"
    using tasim red1' heap unfolding s1' s2 by -(rule exI conjI|assumption|auto)+
next
  fix s1 s2 ta2 s2'
  assume "bisim_red_red0 s1 s2" and "mred0 P t s2 ta2 s2'" "¬ τMOVE0 P s2 ta2 s2'"
  from red_simulates_red0[OF wf this]
  show "s1' s1'' ta1. red_mthr.silent_moves P t s1 s1'  mred P t s1' ta1 s1'' 
                       ¬ τMOVE P s1' ta1 s1''  bisim_red_red0 s1'' s2'  ta_bisim0 ta1 ta2"
    by(blast intro: rtranclp.rtrancl_refl)
qed

lemma delay_bisimulation_diverge_red_red0:
  assumes "wwf_J_prog P"
  shows "delay_bisimulation_diverge (mred P t) (mred0 P t) bisim_red_red0 ta_bisim0 (τMOVE P) (τMOVE0 P)"
proof -
  interpret delay_bisimulation_measure
    "mred P t" "mred0 P t" "bisim_red_red0" "ta_bisim0" "τMOVE P" "τMOVE0 P"
    "λe e'. False" "λ((e, es), h) ((e, es'), h). length es < length es'"
    using assms by(rule delay_bisimulation_measure_red_red0)
  show ?thesis by unfold_locales
qed

lemma bisim_red_red0_finalD:
  assumes bisim: "bisim_red_red0 (x1, m1) (x2, m2)"
  and "final_expr x1"
  shows "x2'. red0_mthr.silent_moves P t (x2, m2) (x2', m2)  bisim_red_red0 (x1, m1) (x2', m2)  final_expr0 x2'"
proof -
  from bisim
  obtain e' e es where wf_state: "wf_state (e, es)"
    and [simp]: "x1 = (e', Map.empty)" "x2 = (e, es)" "e' = collapse (e, es)" "m2 = m1"
    by cases(cases x2, auto)
  from ‹final_expr x1 have "final (collapse (e, es))" by simp
  moreover from wf_state have "eset es. is_call e" by auto
  ultimately have "red0_mthr.silent_moves P t ((e, es), m1) ((collapse (e, es), []), m1)"
  proof(induction es arbitrary: e)
    case Nil thus ?case by simp
  next
    case (Cons e' es)
    from ‹final (collapse (e, e' # es)) have "final (collapse (inline_call e e', es))" by simp
    moreover from eset (e' # es). is_call e have "eset es. is_call e" by simp
    ultimately have "red0_mthr.silent_moves P t ((inline_call e e', es), m1) ((collapse (inline_call e e', es), []), m1)"
      by(rule Cons.IH)
    moreover from ‹final (collapse (e, e' # es)) eset (e' # es). is_call e
    have "final e" by(rule collapse_finalD)
    hence "P,t ⊢0 e/e'#es, m1 -ε inline_call e e'/es, m1" by(rule red0Return)
    with ‹final e have "red0_mthr.silent_move P t ((e, e'#es), m1) ((inline_call e e', es), m1)" by auto
    ultimately show ?case by -(erule converse_rtranclp_into_rtranclp, simp)
  qed
  moreover have "bisim_red_red0 ((collapse (e, es), Map.empty), m1) ((collapse (e, es), []), m1)"
    using ‹final (collapse (e, es)) by(auto intro!: bisim_red_red0I)
  ultimately show ?thesis using ‹final (collapse (e, es)) by auto
qed

lemma red0_simulates_red_not_final:
  assumes wwf: "wwf_J_prog P"
  assumes bisim: "bisim_red_red0 ((e, xs), h) ((e0, es0), h0)"
  and red: "P,t  e, (h, xs) -ta e', (h', xs')"
  and fin: "¬ final e0"
  and: "¬ τmove0 P h e"
  shows "e0' ta0. P,t ⊢0 e0/es0, h -ta0 e0'/es0, h'  bisim_red_red0 ((e', xs'), h') ((e0', es0), h')  ta_bisim0 ta ta0"
proof -
  from bisim have [simp]: "xs = Map.empty" "h0 = h" and e: "e = collapse (e0, es0)"
    and wfs: "wf_state (e0, es0)" by(auto elim!: bisim_red_red0.cases)
  with red have "P,t  collapse (e0, es0), (h, Map.empty) -ta e', (h', xs')" by simp
  from wfs red_fold_exs'[OF this] fin obtain e0' where e': "e' = collapse (e0', es0)"
    and red': "P,t  e0,(h, Map.empty) -ta e0',(h', Map.empty)" by(auto)
  from wfs fv_collapse[of es0, of e0] e have "fv e = {}" by(auto)
  with red_dom_lcl[OF red] have [simp]: "xs' = Map.empty" by simp
  from red_red0_tabisim0[OF wwf red'] obtain ta0
    where red'': "extTA2J0 P,P,t  e0,(h, Map.empty) -ta0 e0',(h', Map.empty)"
    and tasim: "ta_bisim0 ta ta0" by auto
  from nτ e wfs fin have "¬ τmove0 P h e0" by(auto simp add: collapse_τmove0_inv)
  hence "aMvs. call e0 = aMvs  synthesized_call P h aMvs"
    by(auto dest: τmove0_callD)
  with red'' have red''': "P,t ⊢0 e0/es0, h -ta0 e0'/es0, h'" by(rule red0Red)
  moreover from red''' wfs have "wf_state (e0', es0)" by(rule red0_preserves_wf_state[OF wwf])
  hence "bisim_red_red0 ((e', xs'), h') ((e0', es0), h')" unfolding e' by(auto)
  ultimately show ?thesis using tasim by(auto simp del: split_paired_Ex)
qed

lemma red_red0_FWbisim:
  assumes wf: "wwf_J_prog P"
  shows "FWdelay_bisimulation_diverge final_expr (mred P) final_expr0 (mred0 P)
                                      (λt. bisim_red_red0) (λexs (e0, es0). ¬ final e0) (τMOVE P) (τMOVE0 P)"
proof -
  interpret delay_bisimulation_diverge "mred P t" "mred0 P t" "bisim_red_red0" "ta_bisim0" "τMOVE P" "τMOVE0 P"
    for t by(rule delay_bisimulation_diverge_red_red0[OF wf])
  show ?thesis
  proof
    fix t and s1 :: "(('addr expr × 'addr locals) × 'heap)" and s2 :: "(('addr expr × 'addr expr list) × 'heap)"
    assume "bisim_red_red0 s1 s2" "(λ(x1, m). final_expr x1) s1"
    moreover obtain x1 m1 where [simp]: "s1 = (x1, m1)" by(cases s1)
    moreover obtain x2 m2 where [simp]: "s2 = (x2, m2)" by(cases s2)
    ultimately have "bisim_red_red0 (x1, m1) (x2, m2)" "final_expr x1" by simp_all
    from bisim_red_red0_finalD[OF this, of P t]
    show "s2'. red0_mthr.silent_moves P t s2 s2'  bisim_red_red0 s1 s2'  (λ(x2, m). final_expr0 x2) s2'" by auto
  next
    fix t and s1 :: "(('addr expr × 'addr locals) × 'heap)" and s2 :: "(('addr expr × 'addr expr list) × 'heap)"
    assume "bisim_red_red0 s1 s2" "(λ(x2, m). final_expr0 x2) s2"
    moreover obtain x1 m1 where [simp]: "s1 = (x1, m1)" by(cases s1)
    moreover obtain x2 m2 where [simp]: "s2 = (x2, m2)" by(cases s2)
    ultimately have "bisim_red_red0 (x1, m1) (x2, m2)" "final_expr0 x2" by simp_all
    moreover hence "final_expr x1" by(rule bisim_red_red0_final0D)
    ultimately show "s1'. red_mthr.silent_moves P t s1 s1'  bisim_red_red0 s1' s2  (λ(x1, m). final_expr x1) s1'" by auto
  next
    fix t' x m1 xx m2 t x1 x2 x1' ta1 x1'' m1' x2' ta2 x2'' m2'
    assume b: "bisim_red_red0 (x, m1) (xx, m2)" and bo: "bisim_red_red0 (x1, m1) (x2, m2)"
      and "red_mthr.silent_moves P t (x1, m1) (x1', m1)"
      and red1: "mred P t (x1', m1) ta1 (x1'', m1')" and "¬ τMOVE P (x1', m1) ta1 (x1'', m1')"
      and "red0_mthr.silent_moves P t (x2, m2) (x2', m2)"
      and red2: "mred0 P t (x2', m2) ta2 (x2'', m2')" and "¬ τMOVE0 P (x2', m2) ta2 (x2'', m2')"
      and bo': "bisim_red_red0 (x1'', m1') (x2'', m2')"
      and tb: "ta_bisim0 ta1 ta2"
    from b have "m1 = m2" by(auto elim: bisim_red_red0.cases)
    moreover from bo' have "m1' = m2'" by(auto elim: bisim_red_red0.cases)
    ultimately show "bisim_red_red0 (x, m1') (xx, m2')" using b
      by(auto elim: bisim_red_red0.cases)
  next
    fix t x1 m1 x2 m2 x1' ta1 x1'' m1' x2' ta2 x2'' m2' w
    assume b: "bisim_red_red0 (x1, m1) (x2, m2)"
      and "red_mthr.silent_moves P t (x1, m1) (x1', m1)"
      and red1: "mred P t (x1', m1) ta1 (x1'', m1')" and "¬ τMOVE P (x1', m1) ta1 (x1'', m1')"
      and "red0_mthr.silent_moves P t (x2, m2) (x2', m2)" 
      and red2: "mred0 P t (x2', m2) ta2 (x2'', m2')" and "¬ τMOVE0 P (x2', m2) ta2 (x2'', m2')"
      and b': "bisim_red_red0 (x1'', m1') (x2'', m2')" and "ta_bisim0 ta1 ta2"
      and Suspend: "Suspend w  set ta1w" "Suspend w  set ta2w"
    hence "(λexs (e0, es0). is_call e0) x1'' x2''"
      by(cases x1')(cases x2', auto dest: Red_Suspend_is_call simp add: final_iff)
    thus "(λexs (e0, es0). ¬ final e0) x1'' x2''" by(auto simp add: final_iff is_call_def)
  next
    fix t x1 m1 x2 m2 ta1 x1' m1'
    assume b: "bisim_red_red0 (x1, m1) (x2, m2)"
      and c: "(λ(e0, es0). ¬ final e0) x2"
      and red1: "mred P t (x1, m1) ta1 (x1', m1')"
      and wakeup: "Notified  set ta1w  WokenUp  set ta1w"
    from c have "¬ final (fst x2)" by(auto simp add: is_call_def)
    moreover from red1 wakeup have "¬ τmove0 P m1 (fst x1)"
      by(cases x1)(auto dest: red_τ_taD[where extTA="extTA2J P", simplified] simp add: ta_upd_simps)
    moreover from b have "m2 = m1" by(cases) auto
    ultimately obtain e0' ta0 where "P,t ⊢0 fst x2/snd x2,m2 -ta0 e0'/snd x2,m1'"
      "bisim_red_red0 ((fst x1', snd x1'), m1') ((e0', snd x2), m1')" "ta_bisim0 ta1 ta0"
      using red0_simulates_red_not_final[OF wf, of "fst x1" "snd x1" m1 "fst x2" "snd x2" m2 t ta1 "fst x1'" m1' "snd x1'"]
      using b red1 by(auto simp add: split_beta)
    thus "ta2 x2' m2'. mred0 P t (x2, m2) ta2 (x2', m2')  bisim_red_red0 (x1', m1') (x2', m2')  ta_bisim0 ta1 ta2"
      by(cases ta0)(fastforce simp add: split_beta)
  next
    fix t x1 m1 x2 m2 ta2 x2' m2'
    assume b: "bisim_red_red0 (x1, m1) (x2, m2)"
      and c: "(λ(e0, es0). ¬ final e0) x2"
      and red2: "mred0 P t (x2, m2) ta2 (x2', m2')"
      and wakeup: "Notified  set ta2w  WokenUp  set ta2w"
    from b have [simp]: "m1 = m2" by cases auto
    with red_simulates_red0[OF wf b red2] wakeup obtain s1' ta1
      where "mred P t (x1, m1) ta1 s1'" "bisim_red_red0 s1' (x2', m2')" "ta_bisim0 ta1 ta2"
      by(fastforce simp add: split_paired_Ex)
    moreover from ‹bisim_red_red0 s1' (x2', m2') have "m2' = snd s1'" by cases auto
    ultimately
    show "ta1 x1' m1'. mred P t (x1, m1) ta1 (x1', m1')  bisim_red_red0 (x1', m1') (x2', m2')  ta_bisim0 ta1 ta2"
      by(cases ta1)(fastforce simp add: split_beta)
  next
    show "(x. final_expr x)  (x. final_expr0 x)"
      by(auto simp add: final_iff)
  qed
qed

end

sublocale J_heap_base < red_red0:
  FWdelay_bisimulation_base 
    final_expr
    "mred P"
    final_expr0 
    "mred0 P"
    convert_RA
    "λt. bisim_red_red0" 
    "λexs (e0, es0). ¬ final e0"
    "τMOVE P" "τMOVE0 P" 
  for P
by(unfold_locales)

context J_heap_base begin

lemma bisim_J_J0_start:
  assumes wf: "wwf_J_prog P"
  and wf_start: "wf_start_state P C M vs"
  shows "red_red0.mbisim (J_start_state P C M vs) (J0_start_state P C M vs)"
proof -
  from wf_start obtain Ts T pns body D
    where sees: "P  C sees M:TsT=(pns,body) in D"
    and conf: "P,start_heap  vs [:≤] Ts"
    by cases auto

  from conf have vs: "length vs = length Ts" by(rule list_all2_lengthD)
  from sees_wf_mdecl[OF wf sees] 
  have wwfCM: "wwf_J_mdecl P D (M, Ts, T, pns, body)"
    and len: "length pns = length Ts" by(auto simp add: wf_mdecl_def)
  from wwfCM have fvbody: "fv body  {this}  set pns"
    and pns: "length pns = length Ts" by simp_all
  with vs len have fv: "fv (blocks pns Ts vs body)  {this}" by auto
  with len vs sees show ?thesis unfolding start_state_def
    by(auto intro!: red_red0.mbisimI)(auto intro!: bisim_red_red0.intros wset_thread_okI simp add: is_call_def split: if_split_asm)
qed

end

end

Theory J1State

(*  Title:      JinjaThreads/Compiler/J1State.thy
    Author:     Andreas Lochbihler
*)

section ‹The intermediate language J1›

theory J1State imports
  "../J/State"
  CallExpr
begin

type_synonym
  'addr expr1 = "(nat, nat, 'addr) exp"

type_synonym
  'addr J1_prog = "'addr expr1 prog"

type_synonym
  'addr locals1 = "'addr val list"

translations
  (type) "'addr expr1" <= (type) "(nat, nat, 'addr) exp"
  (type) "'addr J1_prog" <= (type) "'addr expr1 prog"

type_synonym
  'addr J1state = "('addr expr1 × 'addr locals1) list"

type_synonym
  ('addr, 'thread_id, 'heap) J1_thread_action = 
  "('addr, 'thread_id, ('addr expr1 × 'addr locals1) × ('addr expr1 × 'addr locals1) list,'heap) Jinja_thread_action"

type_synonym
  ('addr, 'thread_id, 'heap) J1_state = 
  "('addr,'thread_id,('addr expr1 × 'addr locals1) × ('addr expr1 × 'addr locals1) list,'heap,'addr) state"

(* pretty printing for J1_thread_action type *)
print_translation let
    fun tr'
       [a1, t
       , Const (@{type_syntax "prod"}, _) $ 
           (Const (@{type_syntax "prod"}, _) $
              (Const (@{type_syntax "exp"}, _) $ Const (@{type_syntax "nat"}, _) $ Const (@{type_syntax "nat"}, _) $ a2) $
              (Const (@{type_syntax "list"}, _) $ (Const (@{type_syntax "val"}, _) $ a3))) $
           (Const (@{type_syntax "list"}, _) $
              (Const (@{type_syntax "prod"}, _) $
                (Const (@{type_syntax "exp"}, _) $ Const (@{type_syntax "nat"}, _) $ Const (@{type_syntax "nat"}, _) $ a4) $
                (Const (@{type_syntax "list"}, _) $ (Const (@{type_syntax "val"}, _) $ a5))))
       , h] =
      if a1 = a2 andalso a2 = a3 andalso a3 = a4 andalso a4 = a5 
      then Syntax.const @{type_syntax "J1_thread_action"} $ a1 $ t $ h
      else raise Match;
    in [(@{type_syntax "Jinja_thread_action"}, K tr')]
  end
typ "('addr,'thread_id,'heap) J1_thread_action"

(* pretty printing for J1_state type *)
print_translation let
    fun tr'
       [a1, t
       , Const (@{type_syntax "prod"}, _) $ 
           (Const (@{type_syntax "prod"}, _) $
              (Const (@{type_syntax "exp"}, _) $ Const (@{type_syntax "nat"}, _) $ Const (@{type_syntax "nat"}, _) $ a2) $
              (Const (@{type_syntax "list"}, _) $ (Const (@{type_syntax "val"}, _) $ a3))) $
           (Const (@{type_syntax "list"}, _) $
              (Const (@{type_syntax "prod"}, _) $
                (Const (@{type_syntax "exp"}, _) $ Const (@{type_syntax "nat"}, _) $ Const (@{type_syntax "nat"}, _) $ a4) $
                (Const (@{type_syntax "list"}, _) $ (Const (@{type_syntax "val"}, _) $ a5))))
       , h, a6] =
      if a1 = a2 andalso a2 = a3 andalso a3 = a4 andalso a4 = a5 andalso a5 = a6
      then Syntax.const @{type_syntax "J1_state"} $ a1 $ t $ h
      else raise Match;
    in [(@{type_syntax "state"}, K tr')]
  end
typ "('addr, 'thread_id, 'heap) J1_state"

fun blocks1 :: "nat  ty list  (nat,'b,'addr) exp  (nat,'b,'addr) exp"
where 
  "blocks1 n [] e = e"
| "blocks1 n (T#Ts) e = {n:T=None; blocks1 (Suc n) Ts e}"

primrec max_vars:: "('a,'b,'addr) exp  nat"
  and max_varss:: "('a,'b,'addr) exp list  nat"
where
  "max_vars (new C) = 0"
| "max_vars (newA Te) = max_vars e"
| "max_vars (Cast C e) = max_vars e"
| "max_vars (e instanceof T) = max_vars e"
| "max_vars (Val v) = 0"
| "max_vars (e «bop» e') = max (max_vars e) (max_vars e')"
| "max_vars (Var V) = 0"
| "max_vars (V:=e) = max_vars e"
| "max_vars (ai) = max (max_vars a) (max_vars i)"
| "max_vars (AAss a i e) = max (max (max_vars a) (max_vars i)) (max_vars e)"
| "max_vars (a∙length) = max_vars a"
| "max_vars (eF{D}) = max_vars e"
| "max_vars (FAss e1 F D e2) = max (max_vars e1) (max_vars e2)"
| "max_vars (e∙compareAndSwap(DF, e', e'')) = max (max (max_vars e) (max_vars e')) (max_vars e'')"
| "max_vars (eM(es)) = max (max_vars e) (max_varss es)"
| "max_vars ({V:T=vo; e}) = max_vars e + 1"
― ‹sync and insync will need an extra local variable when compiling to bytecode to store the object that is being synchronized on until its release›
| "max_vars (syncV (e') e) = max (max_vars e') (max_vars e + 1)"
| "max_vars (insyncV (a) e) = max_vars e + 1"
| "max_vars (e1;;e2) = max (max_vars e1) (max_vars e2)"
| "max_vars (if (e) e1 else e2) =
   max (max_vars e) (max (max_vars e1) (max_vars e2))"
| "max_vars (while (b) e) = max (max_vars b) (max_vars e)"
| "max_vars (throw e) = max_vars e"
| "max_vars (try e1 catch(C V) e2) = max (max_vars e1) (max_vars e2 + 1)"

| "max_varss [] = 0"
| "max_varss (e#es) = max (max_vars e) (max_varss es)"

― ‹Indices in blocks increase by 1›

primrec  :: "'addr expr1  nat  bool"
  and ℬs :: "'addr expr1 list  nat  bool"
where
  " (new C) i = True"
| " (newA Te) i =  e i"
| " (Cast C e) i =  e i"
| " (e instanceof T) i =  e i"
| " (Val v) i = True"
| " (e1 «bop» e2) i = ( e1 i   e2 i)"
| " (Var j) i = True"
| " (j:=e) i =  e i"
| " (aj) i = ( a i   j i)"
| " (aj:=e) i = ( a i   j i   e i)"
| " (a∙length) i =  a i"
| " (eF{D}) i =  e i"
| " (e1F{D} := e2) i = ( e1 i   e2 i)"
| " (e∙compareAndSwap(DF, e', e'')) i = ( e i   e' i   e'' i)"
| " (eM(es)) i = ( e i  ℬs es i)"
| " ({j:T=vo; e}) i = (i = j   e (i+1))"
| " (syncV (o') e) i = (i = V   o' i   e (i+1))"
| " (insyncV (a) e) i = (i = V   e (i+1))"
| " (e1;;e2) i = ( e1 i   e2 i)"
| " (if (e) e1 else e2) i = ( e i   e1 i   e2 i)"
| " (throw e) i =  e i"
| " (while (e) c) i = ( e i   c i)"
| " (try e1 catch(C j) e2) i = ( e1 i  i=j   e2 (i+1))"

| "ℬs [] i = True"
| "ℬs (e#es) i = ( e i  ℬs es i)"

text ‹
  Variables for monitor addresses do not occur freely in synchonization blocks
›

primrec syncvars :: "('a, 'a, 'addr) exp  bool"
  and syncvarss :: "('a, 'a, 'addr) exp list  bool"
where
  "syncvars (new C) = True"
| "syncvars (newA Te) = syncvars e"
| "syncvars (Cast T e) = syncvars e"
| "syncvars (e instanceof T) = syncvars e"
| "syncvars (Val v) = True"
| "syncvars (e1 «bop» e2) = (syncvars e1  syncvars e2)"
| "syncvars (Var V) = True"
| "syncvars (V:=e) = syncvars e"
| "syncvars (ai) = (syncvars a  syncvars i)"
| "syncvars (ai := e) = (syncvars a  syncvars i  syncvars e)"
| "syncvars (a∙length) = syncvars a"
| "syncvars (eF{D}) = syncvars e"
| "syncvars (eF{D} := e2) = (syncvars e  syncvars e2)"
| "syncvars (e∙compareAndSwap(DF, e', e'')) = (syncvars e  syncvars e'  syncvars e'')"
| "syncvars (eM(es)) = (syncvars e  syncvarss es)"
| "syncvars {V:T=vo;e} = syncvars e"
| "syncvars (syncV (e1) e2) = (syncvars e1  syncvars e2  V  fv e2)"
| "syncvars (insyncV (a) e) = (syncvars e  V  fv e)"
| "syncvars (e1;;e2) = (syncvars e1  syncvars e2)"
| "syncvars (if (b) e1 else e2) = (syncvars b  syncvars e1  syncvars e2)"
| "syncvars (while (b) c) = (syncvars b  syncvars c)"
| "syncvars (throw e) = syncvars e"
| "syncvars (try e1 catch(C V) e2) = (syncvars e1  syncvars e2)"

| "syncvarss [] = True"
| "syncvarss (e#es) = (syncvars e  syncvarss es)"

definition bsok :: "'addr expr1  nat  bool"
where "bsok e n e n  expr_locks e = (λad. 0)"

definition bsoks :: "'addr expr1 list  nat  bool"
where "bsoks es n  ℬs es n  expr_lockss es = (λad. 0)"

primrec call1 :: "('a, 'b, 'addr) exp  ('addr × mname × 'addr val list) option"
  and calls1 :: "('a, 'b, 'addr) exp list  ('addr × mname × 'addr val list) option"
where
  "call1 (new C) = None"
| "call1 (newA Te) = call1 e"
| "call1 (Cast C e) = call1 e"
| "call1 (e instanceof T) = call1 e"
| "call1 (Val v) = None"
| "call1 (Var V) = None"
| "call1 (V:=e) = call1 e"
| "call1 (e «bop» e') = (if is_val e then call1 e' else call1 e)"
| "call1 (ai) = (if is_val a then call1 i else call1 a)"
| "call1 (AAss a i e) = (if is_val a then (if is_val i then call1 e else call1 i) else call1 a)"
| "call1 (a∙length) = call1 a"
| "call1 (eF{D}) = call1 e"
| "call1 (FAss e F D e') = (if is_val e then call1 e' else call1 e)"
| "call1 (CompareAndSwap e D F e' e'') = (if is_val e then (if is_val e' then call1 e'' else call1 e') else call1 e)"
| "call1 (eM(es)) = (if is_val e then
                     (if is_vals es  is_addr e then (THE a. e = addr a, M, THE vs. es = map Val vs) else calls1 es) 
                     else call1 e)"
| "call1 ({V:T=vo; e}) = (case vo of None  call1 e | Some v  None)"
| "call1 (syncV (o') e) = call1 o'"
| "call1 (insyncV (a) e) = call1 e"
| "call1 (e;;e') = call1 e"
| "call1 (if (e) e1 else e2) = call1 e"
| "call1 (while(b) e) = None"
| "call1 (throw e) = call1 e"
| "call1 (try e1 catch(C V) e2) = call1 e1"

| "calls1 [] = None"
| "calls1 (e#es) = (if is_val e then calls1 es else call1 e)"


lemma expr_locks_blocks1 [simp]:
  "expr_locks (blocks1 n Ts e) = expr_locks e"
by(induct n Ts e rule: blocks1.induct) simp_all

lemma max_varss_append [simp]:
  "max_varss (es @ es') = max (max_varss es) (max_varss es')"
by(induct es, auto)

lemma max_varss_map_Val [simp]: "max_varss (map Val vs) = 0"
by(induct vs) auto

lemma blocks1_max_vars:
  "max_vars (blocks1 n Ts e) = max_vars e + length Ts"
by(induct n Ts e rule: blocks1.induct)(auto)

lemma blocks_max_vars:
  " length vs = length pns; length Ts = length pns 
   max_vars (blocks pns Ts vs e) = max_vars e + length pns"
by(induct pns Ts vs e rule: blocks.induct)(auto)

lemma Bs_append [simp]: "ℬs (es @ es') n  ℬs es n  ℬs es' n"
by(induct es) auto

lemma Bs_map_Val [simp]: "ℬs (map Val vs) n"
by(induct vs) auto

lemma B_blocks1 [intro]: "ℬ body (n + length Ts) (blocks1 n Ts body) n"
by(induct n Ts body rule: blocks1.induct)(auto)

lemma B_extRet2J [simp]: "ℬ e n (extRet2J e va) n"
by(cases va) auto

lemma B_inline_call: "e n; n.e' n  (inline_call e' e) n"
  and Bs_inline_calls: " ℬs es n; n.e' n   ℬs (inline_calls e' es) n"
by(induct e and es arbitrary: n and n rule: call.induct calls.induct) auto

lemma syncvarss_append [simp]: "syncvarss (es @ es')  syncvarss es  syncvarss es'"
by(induct es) auto

lemma syncvarss_map_Val [simp]: "syncvarss (map Val vs)"
by(induct vs) auto

lemma bsok_simps [simp]:
  "bsok (new C) n = True"
  "bsok (newA Te) n = bsok e n"
  "bsok (Cast T e) n = bsok e n"
  "bsok (e instanceof T) n = bsok e n"
  "bsok (e1 «bop» e2) n = (bsok e1 n  bsok e2 n)"
  "bsok (Var V) n = True"
  "bsok (Val v) n = True"
  "bsok (V := e) n = bsok e n"
  "bsok (ai) n = (bsok a n  bsok i n)"
  "bsok (ai := e) n = (bsok a n  bsok i n  bsok e n)"
  "bsok (a∙length) n = bsok a n"
  "bsok (eF{D}) n = bsok e n"
  "bsok (eF{D} := e') n = (bsok e n  bsok e' n)"
  "bsok (e∙compareAndSwap(DF, e', e'')) n = (bsok e n  bsok e' n  bsok e'' n)"
  "bsok (eM(ps)) n = (bsok e n  bsoks ps n)"
  "bsok {V:T=vo; e} n = (bsok e (Suc n)  V = n)"
  "bsok (syncV (e) e') n = (bsok e n  bsok e' (Suc n)  V = n)"
  "bsok (insyncV (ad) e) n = False"
  "bsok (e;; e') n = (bsok e n  bsok e' n)"
  "bsok (if (e) e1 else e2) n = (bsok e n  bsok e1 n  bsok e2 n)"
  "bsok (while (b) c) n = (bsok b n  bsok c n)"
  "bsok (throw e) n = bsok e n"
  "bsok (try e catch(C V) e') n = (bsok e n  bsok e' (Suc n)  V = n)"
  and bsoks_simps [simp]:
  "bsoks [] n = True"
  "bsoks (e # es) n = (bsok e n  bsoks es n)"
by(auto simp add: bsok_def bsoks_def fun_eq_iff)

lemma call1_callE:
  assumes "call1 (objM(pns)) = (a, M', vs)"
  obtains (CallObj) "call1 obj = (a, M', vs)"
  | (CallParams) v where "obj = Val v" "calls1 pns = (a, M', vs)"
  | (Call) "obj = addr a" "pns = map Val vs" "M = M'"
using assms by(auto split: if_split_asm simp add: is_vals_conv)

lemma calls1_map_Val_append [simp]:
  "calls1 (map Val vs @ es) = calls1 es"
by(induct vs) simp_all

lemma calls1_map_Val [simp]:
  "calls1 (map Val vs) = None"
by(induct vs) simp_all

lemma fixes e :: "('a, 'b, 'addr) exp" and es :: "('a, 'b, 'addr) exp list"
  shows call1_imp_call: "call1 e = aMvs  call e = aMvs"
  and calls1_imp_calls: "calls1 es = aMvs  calls es = aMvs"
by(induct e and es rule: call1.induct calls1.induct) auto

lemma max_vars_inline_call: "max_vars (inline_call e' e)  max_vars e + max_vars e'"
  and max_varss_inline_calls: "max_varss (inline_calls e' es)  max_varss es + max_vars e'"
by(induct e and es rule: call1.induct calls1.induct) auto

lemmas inline_call_max_vars1 = max_vars_inline_call
lemmas inline_calls_max_varss1 = max_varss_inline_calls

end

Theory J1Heap

(*  Title:      JinjaThreads/Compiler/J1Heap.hty
    Author:     Andreas Lochbihler
*)

section ‹Abstract heap locales for J1 programs›

theory J1Heap imports
  J1State
  "../Common/Conform"
begin

locale J1_heap_base = heap_base +
  constrains addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and sc_spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"

locale J1_heap = heap + 
  constrains addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and sc_spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and P :: "'addr J1_prog"

sublocale J1_heap < J1_heap_base .

locale J1_heap_conf_base = heap_conf_base +
  constrains addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and sc_spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and hconf :: "'heap  bool"
  and P :: "'addr J1_prog"

sublocale J1_heap_conf_base < J1_heap_base .

locale J1_heap_conf = 
  J1_heap_conf_base +
  heap_conf +
  constrains addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and sc_spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and hconf :: "'heap  bool"
  and P :: "'addr J1_prog"

sublocale J1_heap_conf < J1_heap by(unfold_locales)

locale J1_conf_read =
  J1_heap_conf +
  heap_conf_read +
  constrains addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and sc_spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and hconf :: "'heap  bool"
  and P :: "'addr J1_prog"

end

Theory J1

(*  Title:      JinjaThreads/Compiler/J1.thy
    Author:     Andreas Lochbihler
*)

section ‹Semantics of the intermediate language›

theory J1 imports
  J1State
  J1Heap
  "../Framework/FWBisimulation"
begin

abbreviation final_expr1 :: "('addr expr1 × 'addr locals1) × ('addr expr1 × 'addr locals1) list  bool" where
  "final_expr1  λ(ex, exs). final (fst ex)  exs = []"

definition extNTA2J1 :: 
  "'addr J1_prog  (cname × mname × 'addr)  (('addr expr1 × 'addr locals1) × ('addr expr1 × 'addr locals1) list)"
where
  "extNTA2J1 P = (λ(C, M, a). let (D, _, _, meth) = method P C M; body = the meth
                              in (({0:Class D=None; body}, Addr a # replicate (max_vars body) undefined_value), []))"

lemma extNTA2J1_iff [simp]:
  "extNTA2J1 P (C, M, a) = (({0:Class (fst (method P C M))=None; the (snd (snd (snd (method P C M))))}, Addr a # replicate (max_vars (the (snd (snd (snd (method P C M)))))) undefined_value), [])"
by(simp add: extNTA2J1_def split_beta)

abbreviation extTA2J1 :: 
  "'addr J1_prog  ('addr, 'thread_id, 'heap) external_thread_action  ('addr, 'thread_id, 'heap) J1_thread_action"
where "extTA2J1 P  convert_extTA (extNTA2J1 P)"

abbreviation (input) extRet2J1 :: "'addr expr1  'addr extCallRet  'addr expr1"
where "extRet2J1  extRet2J"

lemma max_vars_extRet2J1 [simp]: 
  "max_vars e = 0  max_vars (extRet2J1 e va) = 0"
by(cases va) simp_all

context J1_heap_base begin

abbreviation J1_start_state :: "'addr J1_prog  cname  mname  'addr val list  ('addr, 'thread_id, 'heap) J1_state"
where
  "J1_start_state  
   start_state (λC M Ts T body vs. ((blocks1 0 (Class C # Ts) body, Null # vs @ replicate (max_vars body) undefined_value), []))"

inductive red1 :: 
  "bool  'addr J1_prog  'thread_id  'addr expr1  'heap × 'addr locals1 
   ('addr, 'thread_id, 'heap) external_thread_action  'addr expr1  'heap × 'addr locals1  bool"
  ("_,_,_ ⊢1 ((1_,/_) -_/ (1_,/_))" [51,51,0,0,0,0,0,0] 81)
  and reds1 ::
  "bool  'addr J1_prog  'thread_id  'addr expr1 list  'heap × 'addr locals1
   ('addr, 'thread_id, 'heap) external_thread_action  'addr expr1 list  'heap × 'addr locals1  bool"
  ("_,_,_ ⊢1 ((1_,/_) [-_→]/ (1_,/_))" [51,51,0,0,0,0,0,0] 81)
for uf :: bool and P :: "'addr J1_prog" and t :: 'thread_id
where
  Red1New:
  "(h', a)  allocate h (Class_type C)
   uf,P,t ⊢1 new C, (h, l) -NewHeapElem a (Class_type C) addr a, (h', l)"

| Red1NewFail:
  "allocate h (Class_type C) = {}
   uf,P,t ⊢1 new C, (h, l) -ε THROW OutOfMemory, (h, l)"

| New1ArrayRed:
  "uf,P,t ⊢1 e, s -ta e', s'
   uf,P,t ⊢1 newA Te, s -ta newA Te', s'"

| Red1NewArray:
  " 0 <=s i; (h', a)  allocate h (Array_type T (nat (sint i))) 
   uf,P,t ⊢1 newA TVal (Intg i), (h, l) -NewHeapElem a (Array_type T (nat (sint i))) addr a, (h', l)"

| Red1NewArrayNegative:
  "i <s 0  uf,P,t ⊢1 newA TVal (Intg i), s -ε THROW NegativeArraySize, s"

| Red1NewArrayFail:
  " 0 <=s i; allocate h (Array_type T (nat (sint i))) = {} 
   uf,P,t ⊢1 newA TVal (Intg i), (h, l) -ε THROW OutOfMemory, (h, l)"

| Cast1Red:
  "uf,P,t ⊢1 e, s -ta e', s'
   uf,P,t ⊢1 Cast C e, s -ta Cast C e', s'"

| Red1Cast:
 " typeofhp s v = U; P  U  T 
   uf,P,t ⊢1 Cast T (Val v), s -ε Val v, s"

| Red1CastFail:
  " typeofhp s v = U; ¬ P  U  T 
   uf,P,t ⊢1 Cast T (Val v), s -ε THROW ClassCast, s"

| InstanceOf1Red:
  "uf,P,t ⊢1 e, s -ta e', s'  uf,P,t ⊢1 e instanceof T, s -ta e' instanceof T, s'"

| Red1InstanceOf:
  " typeofhp s v = U; b  v  Null  P  U  T 
    uf,P,t ⊢1 (Val v) instanceof T, s -ε Val (Bool b), s"

| Bin1OpRed1:
  "uf,P,t ⊢1 e, s -ta e', s'  uf,P,t ⊢1 e «bop» e2, s -ta e' «bop» e2, s'"

| Bin1OpRed2:
  "uf,P,t ⊢1 e, s -ta e', s'  uf,P,t ⊢1 (Val v) «bop» e, s -ta (Val v) «bop» e', s'"

| Red1BinOp:
  "binop bop v1 v2 = Some (Inl v) 
  uf,P,t ⊢1 (Val v1) «bop» (Val v2), s -ε Val v, s"

| Red1BinOpFail:
  "binop bop v1 v2 = Some (Inr a) 
  uf,P,t ⊢1 (Val v1) «bop» (Val v2), s -ε Throw a, s"

| Red1Var:
  " (lcl s)!V = v; V < size (lcl s) 
   uf,P,t ⊢1 Var V, s -ε Val v, s"

| LAss1Red:
  "uf,P,t ⊢1 e, s -ta e', s'
   uf,P,t ⊢1 V:=e, s -ta V:=e', s'"

| Red1LAss:
  "V < size l
   uf,P,t ⊢1 V:=(Val v), (h, l) -ε unit, (h, l[V := v])"

| AAcc1Red1:
  "uf,P,t ⊢1 a, s -ta a', s'  uf,P,t ⊢1 ai, s -ta a'i, s'"

| AAcc1Red2:
  "uf,P,t ⊢1 i, s -ta i', s'  uf,P,t ⊢1 (Val a)i, s -ta (Val a)i', s'"

| Red1AAccNull:
  "uf,P,t ⊢1 nullVal i, s -ε THROW NullPointer, s"

| Red1AAccBounds:
  " typeof_addr (hp s) a = Array_type T n; i <s 0  sint i  int n 
   uf,P,t ⊢1 (addr a)Val (Intg i), s -ε THROW ArrayIndexOutOfBounds, s"

| Red1AAcc:
  " typeof_addr h a = Array_type T n; 0 <=s i; sint i < int n;
     heap_read h a (ACell (nat (sint i))) v 
   uf,P,t ⊢1 (addr a)Val (Intg i), (h, xs) -ReadMem a (ACell (nat (sint i))) v Val v, (h, xs)"

| AAss1Red1:
  "uf,P,t ⊢1 a, s -ta a', s'  uf,P,t ⊢1 ai := e, s -ta a'i := e, s'"

| AAss1Red2:
  "uf,P,t ⊢1 i, s -ta i', s'  uf,P,t ⊢1 (Val a)i := e, s -ta (Val a)i' := e, s'"

| AAss1Red3:
  "uf,P,t ⊢1 e, s -ta e', s'  uf,P,t ⊢1 AAss (Val a) (Val i) e, s -ta (Val a)Val i := e', s'"

| Red1AAssNull:
  "uf,P,t ⊢1 AAss null (Val i) (Val e), s -ε THROW NullPointer, s"

| Red1AAssBounds:
  " typeof_addr (hp s) a = Array_type T n; i <s 0  sint i  int n 
   uf,P,t ⊢1 AAss (addr a) (Val (Intg i)) (Val e), s -ε THROW ArrayIndexOutOfBounds, s"

| Red1AAssStore:
  " typeof_addr (hp s) a = Array_type T n; 0 <=s i; sint i < int n;
     typeofhp s w = U; ¬ (P  U  T) 
   uf,P,t ⊢1 AAss (addr a) (Val (Intg i)) (Val w), s -ε THROW ArrayStore, s"

| Red1AAss:
  " typeof_addr h a = Array_type T n; 0 <=s i; sint i < int n; typeofh w = Some U; P  U  T;
     heap_write h a (ACell (nat (sint i))) w h' 
   uf,P,t ⊢1 AAss (addr a) (Val (Intg i)) (Val w), (h, l) -WriteMem a (ACell (nat (sint i))) w unit, (h', l)"

| ALength1Red:
  "uf,P,t ⊢1 a, s -ta a', s'  uf,P,t ⊢1 a∙length, s -ta a'∙length, s'"

| Red1ALength:
  "typeof_addr h a = Array_type T n 
   uf,P,t ⊢1 addr a∙length, (h, xs) -ε Val (Intg (word_of_nat n)), (h, xs)"

| Red1ALengthNull:
  "uf,P,t ⊢1 null∙length, s -ε THROW NullPointer, s"

| FAcc1Red:
  "uf,P,t ⊢1 e, s -ta e', s'  uf,P,t ⊢1 eF{D}, s -ta e'F{D}, s'"

| Red1FAcc:
  "heap_read h a (CField D F) v
   uf,P,t ⊢1 (addr a)F{D}, (h, xs) -ReadMem a (CField D F) v Val v, (h, xs)"

| Red1FAccNull:
  "uf,P,t ⊢1 nullF{D}, s -ε THROW NullPointer, s"

| FAss1Red1:
  "uf,P,t ⊢1 e, s -ta e', s'  uf,P,t ⊢1 eF{D}:=e2, s -ta e'F{D}:=e2, s'"

| FAss1Red2:
  "uf,P,t ⊢1 e, s -ta e', s'  uf,P,t ⊢1 FAss (Val v) F D e, s -ta Val vF{D}:=e', s'"

| Red1FAss:
  "heap_write h a (CField D F) v h' 
  uf,P,t ⊢1 FAss (addr a) F D (Val v), (h, l) -WriteMem a (CField D F) v unit, (h', l)"

| Red1FAssNull:
  "uf,P,t ⊢1 FAss null F D (Val v), s -ε THROW NullPointer, s"

| CAS1Red1:
  "uf,P,t ⊢1 e, s -ta e', s' 
  uf,P,t ⊢1 e∙compareAndSwap(DF, e2, e3), s -ta e'∙compareAndSwap(DF, e2, e3), s'"

| CAS1Red2:
  "uf,P,t ⊢1 e, s -ta e', s' 
  uf,P,t ⊢1 Val v∙compareAndSwap(DF, e, e3), s -ta Val v∙compareAndSwap(DF, e', e3), s'"

| CAS1Red3:
  "uf,P,t ⊢1 e, s -ta e', s' 
  uf,P,t ⊢1 Val v∙compareAndSwap(DF, Val v', e), s -ta Val v∙compareAndSwap(DF, Val v', e'), s'"

| CAS1Null:
  "uf,P,t ⊢1 null∙compareAndSwap(DF, Val v, Val v'), s -ε THROW NullPointer, s"

| Red1CASSucceed:
  " heap_read h a (CField D F) v; heap_write h a (CField D F) v' h'  
  uf,P,t ⊢1 addr a∙compareAndSwap(DF, Val v, Val v'), (h, l) 
  -ReadMem a (CField D F) v, WriteMem a (CField D F) v' 
  true, (h', l)"

| Red1CASFail:
  " heap_read h a (CField D F) v''; v  v''  
  uf,P,t ⊢1 addr a∙compareAndSwap(DF, Val v, Val v'), (h, l) 
  -ReadMem a (CField D F) v'' 
  false, (h, l)"

| Call1Obj:
  "uf,P,t ⊢1 e, s -ta e', s'  uf,P,t ⊢1 eM(es), s -ta e'M(es), s'"

| Call1Params:
  "uf,P,t ⊢1 es, s [-ta→] es',s' 
  uf,P,t ⊢1 (Val v)M(es),s -ta (Val v)M(es'),s'"

| Red1CallExternal:
  " typeof_addr (hp s) a = T; P  class_type_of T sees M:TsTr = Native in D; P,t  aM(vs), hp s -ta→ext va, h';
     e' = extRet2J1 ((addr a)M(map Val vs)) va; s' = (h', lcl s) 
   uf,P,t ⊢1 (addr a)M(map Val vs), s -ta e', s'"

| Red1CallNull:
  "uf,P,t ⊢1 nullM(map Val vs), s -ε THROW NullPointer, s"

| Block1Some:
  "V < length x  uf,P,t ⊢1 {V:T=v; e}, (h, x) -ε {V:T=None; e}, (h, x[V := v])"

| Block1Red:
  "uf,P,t ⊢1 e, (h, x) -ta e', (h', x')
   uf,P,t ⊢1 {V:T=None; e}, (h, x) -ta {V:T=None; e'}, (h', x')"

| Red1Block:
  "uf,P,t ⊢1 {V:T=None; Val u}, s -ε Val u, s"

| Synchronized1Red1:
  "uf,P,t ⊢1 o', s -ta o'', s'  uf,P,t ⊢1 syncV (o') e, s -ta syncV (o'') e, s'"

| Synchronized1Null:
  "V < length xs  uf,P,t ⊢1 syncV (null) e, (h, xs) -ε THROW NullPointer, (h, xs[V := Null])"

| Lock1Synchronized:
  "V < length xs  uf,P,t ⊢1 syncV (addr a) e, (h, xs) -Locka, SyncLock a insyncV (a) e, (h, xs[V := Addr a])"

| Synchronized1Red2:
  "uf,P,t ⊢1 e, s -ta e', s'  uf,P,t ⊢1 insyncV (a) e, s -ta insyncV (a) e', s'"

| Unlock1Synchronized:
  " xs ! V = Addr a'; V < length xs   uf,P,t ⊢1 insyncV (a) (Val v), (h, xs) -Unlocka', SyncUnlock a' Val v, (h, xs)"

| Unlock1SynchronizedNull:
  " xs ! V = Null; V < length xs   uf,P,t ⊢1 insyncV (a) (Val v), (h, xs) -ε THROW NullPointer, (h, xs)"

| Unlock1SynchronizedFail:
  " uf; xs ! V = Addr a'; V < length xs 
   uf,P,t ⊢1 insyncV (a) (Val v), (h, xs) -UnlockFaila' THROW IllegalMonitorState, (h, xs)"

| Seq1Red:
  "uf,P,t ⊢1 e, s -ta e', s'  uf,P,t ⊢1 e;;e2, s -ta e';;e2, s'"

| Red1Seq:
  "uf,P,t ⊢1 Seq (Val v) e, s -ε e, s"

| Cond1Red:
  "uf,P,t ⊢1 b, s -ta b', s'  uf,P,t ⊢1 if (b) e1 else e2, s -ta if (b') e1 else e2, s'"

| Red1CondT:
  "uf,P,t ⊢1 if (true) e1 else e2, s -ε e1, s"

| Red1CondF:
  "uf,P,t ⊢1 if (false) e1 else e2, s -ε e2, s"

| Red1While:
  "uf,P,t ⊢1 while(b) c, s -ε if (b) (c;;while(b) c) else unit, s"

| Throw1Red:
  "uf,P,t ⊢1 e, s -ta e', s'  uf,P,t ⊢1 throw e, s -ta throw e', s'"

| Red1ThrowNull:
  "uf,P,t ⊢1 throw null, s -ε THROW NullPointer, s"

| Try1Red:
  "uf,P,t ⊢1 e, s -ta e', s'  uf,P,t ⊢1 try e catch(C V) e2, s -ta try e' catch(C V) e2, s'"

| Red1Try:
  "uf,P,t ⊢1 try (Val v) catch(C V) e2, s -ε Val v, s"

| Red1TryCatch:
  " typeof_addr h a = Class_type D; P  D * C; V < length x 
   uf,P,t ⊢1 try (Throw a) catch(C V) e2, (h, x) -ε {V:Class C=None; e2}, (h, x[V := Addr a])"

| Red1TryFail:
  " typeof_addr (hp s) a = Class_type D; ¬ P  D * C 
   uf,P,t ⊢1 try (Throw a) catch(C V) e2, s -ε Throw a, s"

| List1Red1:
  "uf,P,t ⊢1 e,s -ta e',s' 
  uf,P,t ⊢1 e#es,s [-ta→] e'#es,s'"

| List1Red2:
  "uf,P,t ⊢1 es,s [-ta→] es',s' 
  uf,P,t ⊢1 Val v # es,s [-ta→] Val v # es',s'"

| New1ArrayThrow: "uf,P,t ⊢1 newA TThrow a, s -ε Throw a, s"
| Cast1Throw: "uf,P,t ⊢1 Cast C (Throw a), s -ε Throw a, s"
| InstanceOf1Throw: "uf,P,t ⊢1 (Throw a) instanceof T, s -ε Throw a, s"
| Bin1OpThrow1: "uf,P,t ⊢1 (Throw a) «bop» e2, s -ε Throw a, s"
| Bin1OpThrow2: "uf,P,t ⊢1 (Val v1) «bop» (Throw a), s -ε Throw a, s"
| LAss1Throw: "uf,P,t ⊢1 V:=(Throw a), s -ε Throw a, s"
| AAcc1Throw1: "uf,P,t ⊢1 (Throw a)i, s -ε Throw a, s"
| AAcc1Throw2: "uf,P,t ⊢1 (Val v)Throw a, s -ε Throw a, s"
| AAss1Throw1: "uf,P,t ⊢1 (Throw a)i := e, s -ε Throw a, s"
| AAss1Throw2: "uf,P,t ⊢1 (Val v)Throw a := e, s -ε Throw a, s"
| AAss1Throw3: "uf,P,t ⊢1 AAss (Val v) (Val i) (Throw a), s -ε Throw a, s"
| ALength1Throw: "uf,P,t ⊢1 (Throw a)∙length, s -ε Throw a, s"
| FAcc1Throw: "uf,P,t ⊢1 (Throw a)F{D}, s -ε Throw a, s"
| FAss1Throw1: "uf,P,t ⊢1 (Throw a)F{D}:=e2, s -ε Throw a, s"
| FAss1Throw2: "uf,P,t ⊢1 FAss (Val v) F D (Throw a), s -ε Throw a, s"
| CAS1Throw: "uf,P,t ⊢1 Throw a∙compareAndSwap(DF, e2, e3), s -ε Throw a, s"
| CAS1Throw2: "uf,P,t ⊢1 Val v∙compareAndSwap(DF, Throw a, e3), s -ε Throw a, s"
| CAS1Throw3: "uf,P,t ⊢1 Val v∙compareAndSwap(DF, Val v', Throw a), s -ε Throw a, s"
| Call1ThrowObj: "uf,P,t ⊢1 (Throw a)M(es), s -ε Throw a, s"
| Call1ThrowParams: " es = map Val vs @ Throw a # es'   uf,P,t ⊢1 (Val v)M(es), s -ε Throw a, s"
| Block1Throw: "uf,P,t ⊢1 {V:T=None; Throw a}, s -ε Throw a, s"
| Synchronized1Throw1: "uf,P,t ⊢1 syncV (Throw a) e, s -ε Throw a, s"
| Synchronized1Throw2:
  " xs ! V = Addr a'; V < length xs 
   uf,P,t ⊢1 insyncV (a) Throw ad, (h, xs) -Unlocka', SyncUnlock a' Throw ad, (h, xs)"
| Synchronized1Throw2Fail:
  " uf; xs ! V = Addr a'; V < length xs 
   uf,P,t ⊢1 insyncV (a) Throw ad, (h, xs) -UnlockFaila' THROW IllegalMonitorState, (h, xs)"
| Synchronized1Throw2Null:
  " xs ! V = Null; V < length xs 
   uf,P,t ⊢1 insyncV (a) Throw ad, (h, xs) -ε THROW NullPointer, (h, xs)"
| Seq1Throw: "uf,P,t ⊢1 (Throw a);;e2, s -ε Throw a, s"
| Cond1Throw: "uf,P,t ⊢1 if (Throw a) e1 else e2, s -ε Throw a, s"
| Throw1Throw: "uf,P,t ⊢1 throw(Throw a), s -ε Throw a, s"

inductive_cases red1_cases:
  "uf,P,t ⊢1 new C, s -ta e', s'"
  "uf,P,t ⊢1 new Te, s -ta e', s'"
  "uf,P,t ⊢1 e «bop» e', s -ta e'', s'"
  "uf,P,t ⊢1 Var V, s -ta e', s'"
  "uf,P,t ⊢1 V:=e, s -ta e', s'"
  "uf,P,t ⊢1 ai, s -ta e', s'"
  "uf,P,t ⊢1 ai := e, s -ta e', s'"
  "uf,P,t ⊢1 a∙length, s -ta e', s'"
  "uf,P,t ⊢1 eF{D}, s -ta e', s'"
  "uf,P,t ⊢1 eF{D} := e2, s -ta e', s'"
  "uf,P,t ⊢1 e∙compareAndSwap(DF, e', e''), s -ta e''', s'"
  "uf,P,t ⊢1 eM(es), s -ta e', s'"
  "uf,P,t ⊢1 {V:T=vo; e}, s -ta e', s'"
  "uf,P,t ⊢1 syncV (o') e, s -ta e', s'"
  "uf,P,t ⊢1 insyncV (a) e, s -ta e', s'"
  "uf,P,t ⊢1 e;;e', s -ta e'', s'"
  "uf,P,t ⊢1 throw e, s  -ta e', s'"
  "uf,P,t ⊢1 try e catch(C V) e'', s  -ta e', s'"

inductive Red1 ::
  "bool  'addr J1_prog  'thread_id  ('addr expr1 × 'addr locals1)  ('addr expr1 × 'addr locals1) list  'heap
   ('addr, 'thread_id, 'heap) J1_thread_action
   ('addr expr1 × 'addr locals1)  ('addr expr1 × 'addr locals1) list  'heap  bool"
  ("_,_,_ ⊢1 ((1_'/_,/_) -_/ (1_'/_,/_))" [51,51,0,0,0,0,0,0,0,0] 81)
for uf :: bool and P :: "'addr J1_prog" and t :: 'thread_id
where

  red1Red:
  "uf,P,t ⊢1 e, (h, x) -ta e', (h', x')
   uf,P,t ⊢1 (e, x)/exs, h -extTA2J1 P ta (e', x')/exs, h'"

| red1Call:
  " call1 e = (a, M, vs); typeof_addr h a = U; 
     P  class_type_of U sees M:TsT = body in D; 
     size vs = size Ts 
   uf,P,t ⊢1 (e, x)/exs, h -ε (blocks1 0 (Class D#Ts) body, Addr a # vs @ replicate (max_vars body) undefined_value)/(e, x)#exs, h"

| red1Return:
  "final e'  uf,P,t ⊢1 (e', x')/(e, x)#exs, h -ε (inline_call e' e, x)/exs, h"

abbreviation mred1g :: "bool  'addr J1_prog  ('addr,'thread_id,('addr expr1 × 'addr locals1) × ('addr expr1 × 'addr locals1) list,'heap,'addr,('addr, 'thread_id) obs_event) semantics"
where "mred1g uf P  λt ((ex, exs), h) ta ((ex', exs'), h'). uf,P,t ⊢1 ex/exs, h -ta ex'/exs', h'"

abbreviation mred1' :: 
  "'addr J1_prog  ('addr,'thread_id,('addr expr1 × 'addr locals1) × ('addr expr1 × 'addr locals1) list,'heap,'addr,('addr, 'thread_id) obs_event) semantics"
where "mred1'  mred1g False"

abbreviation mred1 :: 
  "'addr J1_prog  ('addr,'thread_id,('addr expr1 × 'addr locals1) × ('addr expr1 × 'addr locals1) list,'heap,'addr,('addr, 'thread_id) obs_event) semantics"
where "mred1  mred1g True"

lemma red1_preserves_len: "uf,P,t ⊢1 e, s -ta e', s'  length (lcl s') = length (lcl s)"
  and reds1_preserves_len: "uf,P,t ⊢1 es, s [-ta→] es', s'  length (lcl s') = length (lcl s)"
by(induct rule: red1_reds1.inducts)(auto)

lemma reds1_preserves_elen: "uf,P,t ⊢1 es, s [-ta→] es', s'  length es' = length es"
by(induct es arbitrary: es')(auto elim: reds1.cases)

lemma red1_Val_iff [iff]:
  "¬ uf,P,t ⊢1 Val v, s -ta e', s'"
by(auto elim: red1.cases)

lemma red1_Throw_iff [iff]:
  "¬ uf,P,t ⊢1 Throw a, xs -ta e', s'"
by(auto elim: red1.cases)

lemma reds1_Nil_iff [iff]:
  "¬ uf,P,t ⊢1 [], s [-ta→] es', s'"
by(auto elim: reds1.cases)

lemma reds1_Val_iff [iff]:
  "¬ uf,P,t ⊢1 map Val vs, s [-ta→] es', s'"
by(induct vs arbitrary: es')(auto elim: reds1.cases)

lemma reds1_map_Val_Throw_iff [iff]:
  "¬ uf,P,t ⊢1 map Val vs @ Throw a # es, s [-ta→] es', s'"
by(induct vs arbitrary: es')(auto elim: reds1.cases elim!: red1_cases)

lemma red1_max_vars_decr: "uf,P,t ⊢1 e, s -ta e', s'  max_vars e'  max_vars e" 
  and reds1_max_varss_decr: "uf,P,t ⊢1 es, s [-ta→] es', s'  max_varss es'  max_varss es"
by(induct rule: red1_reds1.inducts)(auto)

lemma red1_new_thread_heap: "uf,P,t ⊢1 e, s -ta e', s'; NewThread t' ex h  set tat   h = hp s'"
  and reds1_new_thread_heap: "uf,P,t ⊢1 es, s [-ta→] es', s'; NewThread t' ex h  set tat   h = hp s'"
apply(induct rule: red1_reds1.inducts)
apply(fastforce dest: red_ext_new_thread_heap simp add: ta_upd_simps)+
done

lemma red1_new_threadD:
  " uf,P,t ⊢1 e, s -ta e', s'; NewThread t' x H  set tat 
   a M vs va T Ts Tr D. P,t  aM(vs), hp s -ta→ext va, hp s'  typeof_addr (hp s) a = T  P  class_type_of T sees M:TsTr = Native in D"
  and reds1_new_threadD:
  " uf,P,t ⊢1 es, s [-ta→] es', s'; NewThread t' x H  set tat 
   a M vs va T Ts Tr D. P,t  aM(vs), hp s -ta→ext va, hp s'  typeof_addr (hp s) a = T  P  class_type_of T sees M:TsTr = Native in D"
by(induct rule: red1_reds1.inducts)(fastforce simp add: ta_upd_simps)+

lemma red1_call_synthesized: " uf,P,t ⊢1 e, s -ta e', s'; call1 e = aMvs   synthesized_call P (hp s) aMvs"
  and reds1_calls_synthesized: " uf,P,t ⊢1 es, s [-ta→] es', s'; calls1 es = aMvs   synthesized_call P (hp s) aMvs"
apply(induct rule: red1_reds1.inducts)
apply(auto split: if_split_asm simp add: is_vals_conv append_eq_map_conv synthesized_call_conv)
apply blast
done

lemma red1_preserves_B: " uf,P,t ⊢1 e, s -ta e', s';e n e' n"
  and reds1_preserves_Bs: " uf,P,t ⊢1 es, s [-ta→] es', s'; ℬs es n  ℬs es' n"
by(induct arbitrary: n and n rule: red1_reds1.inducts)(auto)

end

context J1_heap begin

lemma red1_hext_incr: "uf,P,t ⊢1 e, s -ta e', s'  hext (hp s) (hp s')"
  and reds1_hext_incr: "uf,P,t ⊢1 es, s [-ta→] es', s'  hext (hp s) (hp s')"
by(induct rule: red1_reds1.inducts)(auto intro: hext_heap_ops red_external_hext)

lemma Red1_hext_incr: "uf,P,t ⊢1 ex/exs,h -ta ex'/exs',h'  h  h'"
by(auto elim!: Red1.cases dest: red1_hext_incr)

end

subsection ‹Silent moves›

context J1_heap_base begin 

primrec τmove1 :: "'m prog  'heap  ('a, 'b, 'addr) exp  bool"
  and τmoves1 :: "'m prog  'heap  ('a, 'b, 'addr) exp list  bool"
where
  "τmove1 P h (new C)  False"
| "τmove1 P h (newA Te)  τmove1 P h e  (a. e = Throw a)"
| "τmove1 P h (Cast U e)  τmove1 P h e  final e"
| "τmove1 P h (e instanceof T)  τmove1 P h e  final e"
| "τmove1 P h (e «bop» e')  τmove1 P h e  (a. e = Throw a)  (v. e = Val v  (τmove1 P h e'  final e'))"
| "τmove1 P h (Val v)  False"
| "τmove1 P h (Var V)  True"
| "τmove1 P h (V := e)  τmove1 P h e  final e"
| "τmove1 P h (ai)  τmove1 P h a  (ad. a = Throw ad)  (v. a = Val v  (τmove1 P h i  (a. i = Throw a)))"
| "τmove1 P h (AAss a i e)  τmove1 P h a  (ad. a = Throw ad)  (v. a = Val v  (τmove1 P h i  (a. i = Throw a)  (v. i = Val v  (τmove1 P h e  (a. e = Throw a)))))"
| "τmove1 P h (a∙length)  τmove1 P h a  (ad. a = Throw ad)"
| "τmove1 P h (eF{D})  τmove1 P h e  (a. e = Throw a)"
| "τmove1 P h (FAss e F D e')  τmove1 P h e  (a. e = Throw a)  (v. e = Val v  (τmove1 P h e'  (a. e' = Throw a)))"
| "τmove1 P h (e∙compareAndSwap(DF, e', e''))  τmove1 P h e  (a. e = Throw a)  (v. e = Val v  
  (τmove1 P h e'  (a. e' = Throw a)  (v. e' = Val v  (τmove1 P h e''  (a. e'' = Throw a)))))"
| "τmove1 P h (eM(es))  τmove1 P h e  (a. e = Throw a)  (v. e = Val v  
   (τmoves1 P h es  (vs a es'. es = map Val vs @ Throw a # es')  
    (vs. es = map Val vs  (v = Null  (T C Ts Tr D. typeofh v = T  class_type_of' T = C  P  C sees M:TsTr = Native in D  τexternal_defs D M)))))"
| "τmove1 P h ({V:T=vo; e})  vo  None  τmove1 P h e  final e"
| "τmove1 P h (syncV'(e) e')  τmove1 P h e  (a. e = Throw a)"
| "τmove1 P h (insyncV'(ad) e)  τmove1 P h e"
| "τmove1 P h (e;;e')  τmove1 P h e  final e"
| "τmove1 P h (if (e) e' else e'')  τmove1 P h e  final e"
| "τmove1 P h (while (e) e') = True"
| "τmove1 P h (throw e)  τmove1 P h e  (a. e = Throw a)  e = null"
| "τmove1 P h (try e catch(C V) e')  τmove1 P h e  final e"

| "τmoves1 P h []  False"
| "τmoves1 P h (e # es)  τmove1 P h e  (v. e = Val v  τmoves1 P h es)"

fun τMove1 :: "'m prog  'heap  (('a, 'b, 'addr) exp × 'c) × (('a, 'b, 'addr) exp × 'd) list  bool"
where
  "τMove1 P h ((e, x), exs) = (τmove1 P h e  final e)"

definition τred1g :: "bool  'addr J1_prog  'thread_id  'heap  ('addr expr1 × 'addr locals1)  ('addr expr1 × 'addr locals1)  bool"
where "τred1g uf P t h exs e'xs' = (uf,P,t ⊢1 fst exs, (h, snd exs) -ε fst e'xs', (h, snd e'xs')  τmove1 P h (fst exs))"

definition τreds1g :: 
  "bool  'addr J1_prog  'thread_id  'heap  ('addr expr1 list × 'addr locals1)  ('addr expr1 list × 'addr locals1)  bool"
where
  "τreds1g uf P t h esxs es'xs' =
   (uf,P,t ⊢1 fst esxs, (h, snd esxs) [-ε→] fst es'xs', (h, snd es'xs')  τmoves1 P h (fst esxs))"

abbreviation τred1gt :: 
  "bool  'addr J1_prog  'thread_id  'heap  ('addr expr1 × 'addr locals1)  ('addr expr1 × 'addr locals1)  bool"
where "τred1gt uf P t h  (τred1g uf P t h)^++"

abbreviation τreds1gt ::
  "bool  'addr J1_prog  'thread_id  'heap  ('addr expr1 list × 'addr locals1)  ('addr expr1 list × 'addr locals1)  bool"
where "τreds1gt uf P t h  (τreds1g uf P t h)^++"

abbreviation τred1gr ::
  "bool  'addr J1_prog  'thread_id  'heap  ('addr expr1 × 'addr locals1)  ('addr expr1 × 'addr locals1)  bool"
where "τred1gr uf P t h  (τred1g uf P t h)^**"

abbreviation τreds1gr ::
  "bool  'addr J1_prog  'thread_id  'heap  ('addr expr1 list × 'addr locals1)  ('addr expr1 list × 'addr locals1)  bool"
where "τreds1gr uf P t h  (τreds1g uf P t h)^**"

definition τRed1g ::
  "bool  'addr J1_prog  'thread_id  'heap  ('addr expr1 × 'addr locals1) × (('addr expr1 × 'addr locals1) list)
   ('addr expr1 × 'addr locals1) × (('addr expr1 × 'addr locals1) list)  bool"
where "τRed1g uf P t h exexs ex'exs' = (uf,P,t ⊢1 fst exexs/snd exexs, h -ε fst ex'exs'/snd ex'exs', h  τMove1 P h exexs)"

abbreviation τRed1gt ::
  "bool  'addr J1_prog  'thread_id  'heap  ('addr expr1 × 'addr locals1) × (('addr expr1 × 'addr locals1) list) 
   ('addr expr1 × 'addr locals1) × (('addr expr1 × 'addr locals1) list)  bool"
where "τRed1gt uf P t h  (τRed1g uf P t h)^++"

abbreviation τRed1gr :: 
  "bool  'addr J1_prog  'thread_id  'heap  ('addr expr1 × 'addr locals1) × (('addr expr1 × 'addr locals1) list) 
   ('addr expr1 × 'addr locals1) × (('addr expr1 × 'addr locals1) list)  bool"
where "τRed1gr uf P t h  (τRed1g uf P t h)^**"

abbreviation τred1 :: 
  "'addr J1_prog  'thread_id  'heap  ('addr expr1 × 'addr locals1)  ('addr expr1 × 'addr locals1)  bool"
where "τred1  τred1g True"

abbreviation τreds1 :: 
  "'addr J1_prog  'thread_id  'heap  ('addr expr1 list × 'addr locals1)  ('addr expr1 list × 'addr locals1)  bool"
where "τreds1  τreds1g True"

abbreviation τred1t :: 
  "'addr J1_prog  'thread_id  'heap  ('addr expr1 × 'addr locals1)  ('addr expr1 × 'addr locals1)  bool"
where "τred1t  τred1gt True"

abbreviation τreds1t ::
  "'addr J1_prog  'thread_id  'heap  ('addr expr1 list × 'addr locals1)  ('addr expr1 list × 'addr locals1)  bool"
where "τreds1t  τreds1gt True"

abbreviation τred1r ::
  "'addr J1_prog  'thread_id  'heap  ('addr expr1 × 'addr locals1)  ('addr expr1 × 'addr locals1)  bool"
where "τred1r  τred1gr True"

abbreviation τreds1r ::
  "'addr J1_prog  'thread_id  'heap  ('addr expr1 list × 'addr locals1)  ('addr expr1 list × 'addr locals1)  bool"
where "τreds1r  τreds1gr True"

abbreviation τRed1 ::
  "'addr J1_prog  'thread_id  'heap  ('addr expr1 × 'addr locals1) × (('addr expr1 × 'addr locals1) list)
   ('addr expr1 × 'addr locals1) × (('addr expr1 × 'addr locals1) list)  bool"
where "τRed1  τRed1g True"

abbreviation τRed1t ::
  "'addr J1_prog  'thread_id  'heap  ('addr expr1 × 'addr locals1) × (('addr expr1 × 'addr locals1) list) 
   ('addr expr1 × 'addr locals1) × (('addr expr1 × 'addr locals1) list)  bool"
where "τRed1t  τRed1gt True"

abbreviation τRed1r :: 
  "'addr J1_prog  'thread_id  'heap  ('addr expr1 × 'addr locals1) × (('addr expr1 × 'addr locals1) list) 
   ('addr expr1 × 'addr locals1) × (('addr expr1 × 'addr locals1) list)  bool"
where "τRed1r  τRed1gr True"

abbreviation τred1' :: 
  "'addr J1_prog  'thread_id  'heap  ('addr expr1 × 'addr locals1)  ('addr expr1 × 'addr locals1)  bool"
where "τred1'  τred1g False"

abbreviation τreds1' :: 
  "'addr J1_prog  'thread_id  'heap  ('addr expr1 list × 'addr locals1)  ('addr expr1 list × 'addr locals1)  bool"
where "τreds1'  τreds1g False"

abbreviation τred1't ::
  "'addr J1_prog  'thread_id  'heap  ('addr expr1 × 'addr locals1)  ('addr expr1 × 'addr locals1)  bool"
where "τred1't  τred1gt False"

abbreviation τreds1't :: 
  "'addr J1_prog  'thread_id  'heap  ('addr expr1 list × 'addr locals1)  ('addr expr1 list × 'addr locals1)  bool"
where "τreds1't  τreds1gt False"

abbreviation τred1'r ::
  "'addr J1_prog  'thread_id  'heap  ('addr expr1 × 'addr locals1)  ('addr expr1 × 'addr locals1)  bool"
where "τred1'r  τred1gr False"

abbreviation τreds1'r :: 
  "'addr J1_prog  'thread_id  'heap  ('addr expr1 list × 'addr locals1)  ('addr expr1 list × 'addr locals1)  bool"
where "τreds1'r  τreds1gr False"

abbreviation τRed1' ::
  "'addr J1_prog  'thread_id  'heap  ('addr expr1 × 'addr locals1) × (('addr expr1 × 'addr locals1) list) 
   ('addr expr1 × 'addr locals1) × (('addr expr1 × 'addr locals1) list)  bool"
where "τRed1'  τRed1g False"

abbreviation τRed1't ::
  "'addr J1_prog  'thread_id  'heap  ('addr expr1 × 'addr locals1) × (('addr expr1 × 'addr locals1) list) 
   ('addr expr1 × 'addr locals1) × (('addr expr1 × 'addr locals1) list)  bool"
where "τRed1't  τRed1gt False"

abbreviation τRed1'r :: 
  "'addr J1_prog  'thread_id  'heap  ('addr expr1 × 'addr locals1) × (('addr expr1 × 'addr locals1) list) 
   ('addr expr1 × 'addr locals1) × (('addr expr1 × 'addr locals1) list)  bool"
where "τRed1'r  τRed1gr False"

abbreviation τMOVE1 :: 
  "'m prog  ((('addr expr1 × 'addr locals1) × ('addr expr1 × 'addr locals1) list) × 'heap, ('addr, 'thread_id, 'heap) J1_thread_action) trsys"
where "τMOVE1 P  λ(exexs, h) ta s. τMove1 P h exexs  ta = ε"

lemma τmove1_τmoves1_intros:
  fixes e :: "('a, 'b, 'addr) exp" and es :: "('a, 'b, 'addr) exp list"
  shows τmove1NewArray: "τmove1 P h e  τmove1 P h (newA Te)"
  and τmove1Cast: "τmove1 P h e  τmove1 P h (Cast U e)"
  and τmove1CastRed: "τmove1 P h (Cast U (Val v))"
  and τmove1InstanceOf: "τmove1 P h e  τmove1 P h (e instanceof U)"
  and τmove1InstanceOfRed: "τmove1 P h ((Val v) instanceof U)"
  and τmove1BinOp1: "τmove1 P h e  τmove1 P h (e«bop»e')"
  and τmove1BinOp2: "τmove1 P h e  τmove1 P h (Val v«bop»e)"
  and τmove1BinOp: "τmove1 P h (Val v«bop»Val v')"
  and τmove1Var: "τmove1 P h (Var V)"
  and τmove1LAss: "τmove1 P h e  τmove1 P h (V := e)"
  and τmove1LAssRed: "τmove1 P h (V := Val v)"
  and τmove1AAcc1: "τmove1 P h e  τmove1 P h (ee')"
  and τmove1AAcc2: "τmove1 P h e  τmove1 P h (Val ve)"
  and τmove1AAss1: "τmove1 P h e  τmove1 P h (AAss e e' e'')"
  and τmove1AAss2: "τmove1 P h e  τmove1 P h (AAss (Val v) e e')"
  and τmove1AAss3: "τmove1 P h e  τmove1 P h (AAss (Val v) (Val v') e)"
  and τmove1ALength: "τmove1 P h e  τmove1 P h (e∙length)"
  and τmove1FAcc: "τmove1 P h e  τmove1 P h (eF{D})"
  and τmove1FAss1: "τmove1 P h e  τmove1 P h (FAss e F D e')"
  and τmove1FAss2: "τmove1 P h e  τmove1 P h (FAss (Val v) F D e)"
  and τmove1CAS1: "τmove1 P h e  τmove1 P h (e∙compareAndSwap(DF, e', e''))"
  and τmove1CAS2: "τmove1 P h e  τmove1 P h (Val v∙compareAndSwap(DF, e, e''))"
  and τmove1CAS3: "τmove1 P h e  τmove1 P h (Val v∙compareAndSwap(DF, Val v', e))"
  and τmove1CallObj: "τmove1 P h obj  τmove1 P h (objM(ps))"
  and τmove1CallParams: "τmoves1 P h ps  τmove1 P h (Val vM(ps))"
  and τmove1Call: "(T C Ts Tr D.  typeofh v = T; class_type_of' T = C; P  C sees M:TsTr = Native in D   τexternal_defs D M)  τmove1 P h (Val vM(map Val vs))"
  and τmove1BlockSome: "τmove1 P h {V:T=v; e}"
  and τmove1Block: "τmove1 P h e  τmove1 P h {V:T=None; e}"
  and τmove1BlockRed: "τmove1 P h {V:T=None; Val v}"
  and τmove1Sync: "τmove1 P h e  τmove1 P h (syncV' (e) e')"
  and τmove1InSync: "τmove1 P h e  τmove1 P h (insyncV' (a) e)"
  and τmove1Seq: "τmove1 P h e  τmove1 P h (e;;e')"
  and τmove1SeqRed: "τmove1 P h (Val v;; e)"
  and τmove1Cond: "τmove1 P h e  τmove1 P h (if (e) e1 else e2)"
  and τmove1CondRed: "τmove1 P h (if (Val v) e1 else e2)"
  and τmove1WhileRed: "τmove1 P h (while (c) e)"
  and τmove1Throw: "τmove1 P h e  τmove1 P h (throw e)"
  and τmove1ThrowNull: "τmove1 P h (throw null)"
  and τmove1Try: "τmove1 P h e  τmove1 P h (try e catch(C V) e'')"
  and τmove1TryRed: "τmove1 P h (try Val v catch(C V) e)"
  and τmove1TryThrow: "τmove1 P h (try Throw a catch(C V) e)"
  and τmove1NewArrayThrow: "τmove1 P h (newA TThrow a)"
  and τmove1CastThrow: "τmove1 P h (Cast T (Throw a))"
  and τmove1InstanceOfThrow: "τmove1 P h ((Throw a) instanceof T)"
  and τmove1BinOpThrow1: "τmove1 P h (Throw a «bop» e2)"
  and τmove1BinOpThrow2: "τmove1 P h (Val v «bop» Throw a)"
  and τmove1LAssThrow: "τmove1 P h (V:=(Throw a))"
  and τmove1AAccThrow1: "τmove1 P h (Throw ae)"
  and τmove1AAccThrow2: "τmove1 P h (Val vThrow a)"
  and τmove1AAssThrow1: "τmove1 P h (AAss (Throw a) e e')"
  and τmove1AAssThrow2: "τmove1 P h (AAss (Val v) (Throw a) e')"
  and τmove1AAssThrow3: "τmove1 P h (AAss (Val v) (Val v') (Throw a))"
  and τmove1ALengthThrow: "τmove1 P h (Throw a∙length)"
  and τmove1FAccThrow: "τmove1 P h (Throw aF{D})"
  and τmove1FAssThrow1: "τmove1 P h (Throw aF{D} := e)"
  and τmove1FAssThrow2: "τmove1 P h (FAss (Val v) F D (Throw a))"
  and τmove1CASThrow1: "τmove1 P h (CompareAndSwap (Throw a) D F e e')"
  and τmove1CASThrow2: "τmove1 P h (CompareAndSwap (Val v) D F (Throw a) e')"
  and τmove1CASThrow3: "τmove1 P h (CompareAndSwap (Val v) D F (Val v') (Throw a))"
  and τmove1CallThrowObj: "τmove1 P h (Throw aM(es))"
  and τmove1CallThrowParams: "τmove1 P h (Val vM(map Val vs @ Throw a # es))"
  and τmove1BlockThrow: "τmove1 P h {V:T=None; Throw a}"
  and τmove1SyncThrow: "τmove1 P h (syncV' (Throw a) e)"
  and τmove1SeqThrow: "τmove1 P h (Throw a;;e)"
  and τmove1CondThrow: "τmove1 P h (if (Throw a) e1 else e2)"
  and τmove1ThrowThrow: "τmove1 P h (throw (Throw a))"

  and τmoves1Hd: "τmove1 P h e  τmoves1 P h (e # es)"
  and τmoves1Tl: "τmoves1 P h es  τmoves1 P h (Val v # es)"
by fastforce+

lemma τmoves1_map_Val [dest!]:
  "τmoves1 P h (map Val es)  False"
by(induct es)(auto)

lemma τmoves1_map_Val_ThrowD [simp]: "τmoves1 P h (map Val vs @ Throw a # es) = False"
by(induct vs)(fastforce)+

lemma fixes e :: "('a, 'b, 'addr) exp" and es :: "('a, 'b, 'addr) exp list"
  shows τmove1_not_call1:
  "call1 e = (a, M, vs)  τmove1 P h e  (synthesized_call P h (a, M, vs)  τexternal' P h a M)"
  and τmoves1_not_calls1:
  "calls1 es = (a, M, vs)  τmoves1 P h es  (synthesized_call P h (a, M, vs)  τexternal' P h a M)"
apply(induct e and es rule: call1.induct calls1.induct)
apply(auto split: if_split_asm simp add: is_vals_conv)
apply(fastforce simp add: synthesized_call_def map_eq_append_conv τexternal'_def τexternal_def dest: sees_method_fun)+
done

lemma red1_τ_taD: " uf,P,t ⊢1 e, s -ta e', s'; τmove1 P (hp s) e   ta = ε"
  and reds1_τ_taD: " uf,P,t ⊢1 es, s [-ta→] es', s'; τmoves1 P (hp s) es   ta = ε"
apply(induct rule: red1_reds1.inducts)
apply(fastforce simp add: map_eq_append_conv τexternal'_def τexternal_def dest: τexternal'_red_external_TA_empty)+
done

lemma τmove1_heap_unchanged: " uf,P,t ⊢1 e, s -ta e', s'; τmove1 P (hp s) e   hp s' = hp s"
  and τmoves1_heap_unchanged: " uf,P,t ⊢1 es, s [-ta→] es', s'; τmoves1 P (hp s) es   hp s' = hp s"
apply(induct rule: red1_reds1.inducts)
apply(auto)
apply(fastforce simp add: map_eq_append_conv τexternal'_def τexternal_def dest: τexternal'_red_external_heap_unchanged)+
done

lemma τMove1_iff:
  "τMove1 P h exexs  (let ((e, _), _) = exexs in τmove1 P h e  final e)"
by(cases exexs)(auto)


lemma τred1_iff [iff]:
  "τred1g uf P t h (e, xs) (e', xs') = (uf,P,t ⊢1 e, (h, xs) -ε e', (h, xs')  τmove1 P h e)"
by(simp add: τred1g_def)

lemma τreds1_iff [iff]:
  "τreds1g uf P t h (es, xs) (es', xs') = (uf,P,t ⊢1 es, (h, xs) [-ε→] es', (h, xs')  τmoves1 P h es)"
by(simp add: τreds1g_def)

lemma τred1t_1step:
  " uf,P,t ⊢1 e, (h, xs) -ε e', (h, xs'); τmove1 P h e 
   τred1gt uf P t h (e, xs) (e', xs')"
by(blast intro: tranclp.r_into_trancl)

lemma τred1t_2step:
  " uf,P,t ⊢1 e, (h, xs) -ε e', (h, xs'); τmove1 P h e; 
     uf,P,t ⊢1 e', (h, xs') -ε e'', (h, xs''); τmove1 P h e' 
   τred1gt uf P t h (e, xs) (e'', xs'')"
by(blast intro: tranclp.trancl_into_trancl[OF τred1t_1step])

lemma τred1t_3step:
  " uf,P,t ⊢1 e, (h, xs) -ε e', (h, xs'); τmove1 P h e; 
     uf,P,t ⊢1 e', (h, xs') -ε e'', (h, xs''); τmove1 P h e';
     uf,P,t ⊢1 e'', (h, xs'') -ε e''', (h, xs'''); τmove1 P h e'' 
   τred1gt uf P t h (e, xs) (e''', xs''')"
by(blast intro: tranclp.trancl_into_trancl[OF τred1t_2step])

lemma τreds1t_1step:
  " uf,P,t ⊢1 es, (h, xs) [-ε→] es', (h, xs'); τmoves1 P h es 
   τreds1gt uf P t h (es, xs) (es', xs')"
by(blast intro: tranclp.r_into_trancl)

lemma τreds1t_2step:
  " uf,P,t ⊢1 es, (h, xs) [-ε→] es', (h, xs'); τmoves1 P h es; 
     uf,P,t ⊢1 es', (h, xs') [-ε→] es'', (h, xs''); τmoves1 P h es' 
   τreds1gt uf P t h (es, xs) (es'', xs'')"
by(blast intro: tranclp.trancl_into_trancl[OF τreds1t_1step])

lemma τreds1t_3step:
  " uf,P,t ⊢1 es, (h, xs) [-ε→] es', (h, xs'); τmoves1 P h es; 
     uf,P,t ⊢1 es', (h, xs') [-ε→] es'', (h, xs''); τmoves1 P h es';
     uf,P,t ⊢1 es'', (h, xs'') [-ε→] es''', (h, xs'''); τmoves1 P h es'' 
   τreds1gt uf P t h (es, xs) (es''', xs''')"
by(blast intro: tranclp.trancl_into_trancl[OF τreds1t_2step])

lemma τred1r_1step:
  " uf,P,t ⊢1 e, (h, xs) -ε e', (h, xs'); τmove1 P h e 
   τred1gr uf P t h (e, xs) (e', xs')"
by(blast intro: r_into_rtranclp)

lemma τred1r_2step:
  " uf,P,t ⊢1 e, (h, xs) -ε e', (h, xs'); τmove1 P h e; 
     uf,P,t ⊢1 e', (h, xs') -ε e'', (h, xs''); τmove1 P h e' 
   τred1gr uf P t h (e, xs) (e'', xs'')"
by(blast intro: rtranclp.rtrancl_into_rtrancl[OF τred1r_1step])

lemma τred1r_3step:
  " uf,P,t ⊢1 e, (h, xs) -ε e', (h, xs'); τmove1 P h e; 
     uf,P,t ⊢1 e', (h, xs') -ε e'', (h, xs''); τmove1 P h e';
     uf,P,t ⊢1 e'', (h, xs'') -ε e''', (h, xs'''); τmove1 P h e'' 
   τred1gr uf P t h (e, xs) (e''', xs''')"
by(blast intro: rtranclp.rtrancl_into_rtrancl[OF τred1r_2step])

lemma τreds1r_1step:
  " uf,P,t ⊢1 es, (h, xs) [-ε→] es', (h, xs'); τmoves1 P h es 
   τreds1gr uf P t h (es, xs) (es', xs')"
by(blast intro: r_into_rtranclp)

lemma τreds1r_2step:
  " uf,P,t ⊢1 es, (h, xs) [-ε→] es', (h, xs'); τmoves1 P h es; 
     uf,P,t ⊢1 es', (h, xs') [-ε→] es'', (h, xs''); τmoves1 P h es' 
   τreds1gr uf P t h (es, xs) (es'', xs'')"
by(blast intro: rtranclp.rtrancl_into_rtrancl[OF τreds1r_1step])

lemma τreds1r_3step:
  " uf,P,t ⊢1 es, (h, xs) [-ε→] es', (h, xs'); τmoves1 P h es; 
     uf,P,t ⊢1 es', (h, xs') [-ε→] es'', (h, xs''); τmoves1 P h es';
     uf,P,t ⊢1 es'', (h, xs'') [-ε→] es''', (h, xs'''); τmoves1 P h es'' 
   τreds1gr uf P t h (es, xs) (es''', xs''')"
by(blast intro: rtranclp.rtrancl_into_rtrancl[OF τreds1r_2step])

lemma τred1t_preserves_len: "τred1gt uf P t h (e, xs) (e', xs')  length xs' = length xs"
by(induct rule: tranclp_induct2)(auto dest: red1_preserves_len)

lemma τred1r_preserves_len: "τred1gr uf P t h (e, xs) (e', xs')  length xs' = length xs"
by(induct rule: rtranclp_induct2)(auto dest: red1_preserves_len)

lemma τred1t_inj_τreds1t: "τred1gt uf P t h (e, xs) (e', xs')  τreds1gt uf P t h (e # es, xs) (e' # es, xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl List1Red1 τmoves1Hd)

lemma τreds1t_cons_τreds1t: "τreds1gt uf P t h (es, xs) (es', xs')  τreds1gt uf P t h (Val v # es, xs) (Val v # es', xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl List1Red2 τmoves1Tl)

lemma τred1r_inj_τreds1r: "τred1gr uf P t h (e, xs) (e', xs')  τreds1gr uf P t h (e # es, xs) (e' # es, xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl List1Red1 τmoves1Hd)

lemma τreds1r_cons_τreds1r: "τreds1gr uf P t h (es, xs) (es', xs')  τreds1gr uf P t h (Val v # es, xs) (Val v # es', xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl List1Red2 τmoves1Tl)

lemma NewArray_τred1t_xt:
  "τred1gt uf P t h (e, xs) (e', xs')  τred1gt uf P t h (newA Te, xs) (newA Te', xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl New1ArrayRed τmove1NewArray)

lemma Cast_τred1t_xt:
  "τred1gt uf P t h (e, xs) (e', xs')  τred1gt uf P t h (Cast T e, xs) (Cast T e', xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl Cast1Red τmove1Cast)

lemma InstanceOf_τred1t_xt:
  "τred1gt uf P t h (e, xs) (e', xs')  τred1gt uf P t h (e instanceof T, xs) (e' instanceof T, xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl InstanceOf1Red τmove1InstanceOf)

lemma BinOp_τred1t_xt1:
  "τred1gt uf P t h (e1, xs) (e1', xs')  τred1gt uf P t h (e1 «bop» e2, xs) (e1' «bop» e2, xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl Bin1OpRed1 τmove1BinOp1)

lemma BinOp_τred1t_xt2:
  "τred1gt uf P t h (e2, xs) (e2', xs')  τred1gt uf P t h (Val v «bop» e2, xs) (Val v «bop» e2', xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl Bin1OpRed2 τmove1BinOp2)

lemma LAss_τred1t:
  "τred1gt uf P t h (e, xs) (e', xs')  τred1gt uf P t h (V := e, xs) (V := e', xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl LAss1Red τmove1LAss)

lemma AAcc_τred1t_xt1:
  "τred1gt uf P t h (a, xs) (a', xs')  τred1gt uf P t h (ai, xs) (a'i, xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl AAcc1Red1 τmove1AAcc1)

lemma AAcc_τred1t_xt2:
  "τred1gt uf P t h (i, xs) (i', xs')  τred1gt uf P t h (Val ai, xs) (Val ai', xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl AAcc1Red2 τmove1AAcc2)

lemma AAss_τred1t_xt1:
  "τred1gt uf P t h (a, xs) (a', xs')  τred1gt uf P t h (ai := e, xs) (a'i := e, xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl AAss1Red1 τmove1AAss1)

lemma AAss_τred1t_xt2:
  "τred1gt uf P t h (i, xs) (i', xs')  τred1gt uf P t h (Val ai := e, xs) (Val ai' := e, xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl AAss1Red2 τmove1AAss2)

lemma AAss_τred1t_xt3:
  "τred1gt uf P t h (e, xs) (e', xs')  τred1gt uf P t h (Val aVal i := e, xs) (Val aVal i := e', xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl AAss1Red3 τmove1AAss3)

lemma ALength_τred1t_xt:
  "τred1gt uf P t h (a, xs) (a', xs')  τred1gt uf P t h (a∙length, xs) (a'∙length, xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl ALength1Red τmove1ALength)

lemma FAcc_τred1t_xt:
  "τred1gt uf P t h (e, xs) (e', xs')  τred1gt uf P t h (eF{D}, xs) (e'F{D}, xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl FAcc1Red τmove1FAcc)

lemma FAss_τred1t_xt1:
  "τred1gt uf P t h (e, xs) (e', xs')  τred1gt uf P t h (eF{D} := e2, xs) (e'F{D} := e2, xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl FAss1Red1 τmove1FAss1)

lemma FAss_τred1t_xt2:
  "τred1gt uf P t h (e, xs) (e', xs')  τred1gt uf P t h (Val vF{D} := e, xs) (Val vF{D} := e', xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl FAss1Red2 τmove1FAss2)

lemma CAS_τred1t_xt1:
  "τred1gt uf P t h (e, xs) (e', xs')  τred1gt uf P t h (e∙compareAndSwap(DF, e2, e3), xs) (e'∙compareAndSwap(DF, e2, e3), xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl CAS1Red1)

lemma CAS_τred1t_xt2:
  "τred1gt uf P t h (e, xs) (e', xs')  τred1gt uf P t h (Val v∙compareAndSwap(DF, e, e3), xs) (Val v∙compareAndSwap(DF, e', e3), xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl CAS1Red2)

lemma CAS_τred1t_xt3:
  "τred1gt uf P t h (e, xs) (e', xs')  τred1gt uf P t h (Val v∙compareAndSwap(DF, Val v', e), xs) (Val v∙compareAndSwap(DF, Val v', e'), xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl CAS1Red3)

lemma Call_τred1t_obj:
  "τred1gt uf P t h (e, xs) (e', xs')  τred1gt uf P t h (eM(ps), xs) (e'M(ps), xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl Call1Obj τmove1CallObj)

lemma Call_τred1t_param:
  "τreds1gt uf P t h (es, xs) (es', xs')  τred1gt uf P t h (Val vM(es), xs) (Val vM(es'), xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl Call1Params τmove1CallParams)

lemma Block_None_τred1t_xt:
  "τred1gt uf P t h (e, xs) (e', xs')  τred1gt uf P t h ({V:T=None; e}, xs) ({V:T=None; e'}, xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl τmove1Block elim!: Block1Red)

lemma Block_τred1t_Some:
  " τred1gt uf P t h (e, xs[V := v]) (e', xs'); V < length xs  
   τred1gt uf P t h ({V:Ty=v; e}, xs) ({V:Ty=None; e'}, xs')"
by(blast intro: tranclp_into_tranclp2 Block1Some τmove1BlockSome Block_None_τred1t_xt)

lemma Sync_τred1t_xt:
  "τred1gt uf P t h (e, xs) (e', xs')  τred1gt uf P t h (syncV (e) e2, xs) (syncV (e') e2, xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl Synchronized1Red1 τmove1Sync)

lemma InSync_τred1t_xt:
  "τred1gt uf P t h (e, xs) (e', xs')  τred1gt uf P t h (insyncV (a) e, xs) (insyncV (a) e', xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl Synchronized1Red2 τmove1InSync)

lemma Seq_τred1t_xt:
  "τred1gt uf P t h (e, xs) (e', xs')  τred1gt uf P t h (e;;e2, xs) (e';;e2, xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl Seq1Red τmove1Seq)

lemma Cond_τred1t_xt:
  "τred1gt uf P t h (e, xs) (e', xs')  τred1gt uf P t h (if (e) e1 else e2, xs) (if (e') e1 else e2, xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl Cond1Red τmove1Cond)

lemma Throw_τred1t_xt:
  "τred1gt uf P t h (e, xs) (e', xs')  τred1gt uf P t h (throw e, xs) (throw e', xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl Throw1Red τmove1Throw)

lemma Try_τred1t_xt:
  "τred1gt uf P t h (e, xs) (e', xs')  τred1gt uf P t h (try e catch(C V) e2, xs) (try e' catch(C V) e2, xs')"
by(induct rule: tranclp_induct2)(auto intro: tranclp.trancl_into_trancl Try1Red τmove1Try)


lemma NewArray_τred1r_xt:
  "τred1gr uf P t h (e, xs) (e', xs')  τred1gr uf P t h (newA Te, xs) (newA Te', xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl New1ArrayRed τmove1NewArray)

lemma Cast_τred1r_xt:
  "τred1gr uf P t h (e, xs) (e', xs')  τred1gr uf P t h (Cast T e, xs) (Cast T e', xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl Cast1Red τmove1Cast)

lemma InstanceOf_τred1r_xt:
  "τred1gr uf P t h (e, xs) (e', xs')  τred1gr uf P t h (e instanceof T, xs) (e' instanceof T, xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl InstanceOf1Red τmove1InstanceOf)

lemma BinOp_τred1r_xt1:
  "τred1gr uf P t h (e1, xs) (e1', xs')  τred1gr uf P t h (e1 «bop» e2, xs) (e1' «bop» e2, xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl Bin1OpRed1 τmove1BinOp1)

lemma BinOp_τred1r_xt2:
  "τred1gr uf P t h (e2, xs) (e2', xs')  τred1gr uf P t h (Val v «bop» e2, xs) (Val v «bop» e2', xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl Bin1OpRed2 τmove1BinOp2)

lemma LAss_τred1r:
  "τred1gr uf P t h (e, xs) (e', xs')  τred1gr uf P t h (V := e, xs) (V := e', xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl LAss1Red τmove1LAss)

lemma AAcc_τred1r_xt1:
  "τred1gr uf P t h (a, xs) (a', xs')  τred1gr uf P t h (ai, xs) (a'i, xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl AAcc1Red1 τmove1AAcc1)

lemma AAcc_τred1r_xt2:
  "τred1gr uf P t h (i, xs) (i', xs')  τred1gr uf P t h (Val ai, xs) (Val ai', xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl AAcc1Red2 τmove1AAcc2)

lemma AAss_τred1r_xt1:
  "τred1gr uf P t h (a, xs) (a', xs')  τred1gr uf P t h (ai := e, xs) (a'i := e, xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl AAss1Red1 τmove1AAss1)

lemma AAss_τred1r_xt2:
  "τred1gr uf P t h (i, xs) (i', xs')  τred1gr uf P t h (Val ai := e, xs) (Val ai' := e, xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl AAss1Red2 τmove1AAss2)

lemma AAss_τred1r_xt3:
  "τred1gr uf P t h (e, xs) (e', xs')  τred1gr uf P t h (Val aVal i := e, xs) (Val aVal i := e', xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl AAss1Red3 τmove1AAss3)

lemma ALength_τred1r_xt:
  "τred1gr uf P t h (a, xs) (a', xs')  τred1gr uf P t h (a∙length, xs) (a'∙length, xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl ALength1Red τmove1ALength)

lemma FAcc_τred1r_xt:
  "τred1gr uf P t h (e, xs) (e', xs')  τred1gr uf P t h (eF{D}, xs) (e'F{D}, xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl FAcc1Red τmove1FAcc)

lemma FAss_τred1r_xt1:
  "τred1gr uf P t h (e, xs) (e', xs')  τred1gr uf P t h (eF{D} := e2, xs) (e'F{D} := e2, xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl FAss1Red1 τmove1FAss1)

lemma FAss_τred1r_xt2:
  "τred1gr uf P t h (e, xs) (e', xs')  τred1gr uf P t h (Val vF{D} := e, xs) (Val vF{D} := e', xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl FAss1Red2 τmove1FAss2)

lemma CAS_τred1r_xt1:
  "τred1gr uf P t h (e, xs) (e', xs')  τred1gr uf P t h (e∙compareAndSwap(DF, e2, e3), xs) (e'∙compareAndSwap(DF, e2, e3), xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl CAS1Red1)

lemma CAS_τred1r_xt2:
  "τred1gr uf P t h (e, xs) (e', xs')  τred1gr uf P t h (Val v∙compareAndSwap(DF, e, e3), xs) (Val v∙compareAndSwap(DF, e', e3), xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl CAS1Red2)

lemma CAS_τred1r_xt3:
  "τred1gr uf P t h (e, xs) (e', xs')  τred1gr uf P t h (Val v∙compareAndSwap(DF, Val v', e), xs) (Val v∙compareAndSwap(DF, Val v', e'), xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl CAS1Red3)

lemma Call_τred1r_obj:
  "τred1gr uf P t h (e, xs) (e', xs')  τred1gr uf P t h (eM(ps), xs) (e'M(ps), xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl Call1Obj τmove1CallObj)

lemma Call_τred1r_param:
  "τreds1gr uf P t h (es, xs) (es', xs')  τred1gr uf P t h (Val vM(es), xs) (Val vM(es'), xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl Call1Params τmove1CallParams)

lemma Block_None_τred1r_xt:
  "τred1gr uf P t h (e, xs) (e', xs')  τred1gr uf P t h ({V:T=None; e}, xs) ({V:T=None; e'}, xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl τmove1Block elim!: Block1Red)

lemma Block_τred1r_Some:
  " τred1gr uf P t h (e, xs[V := v]) (e', xs'); V < length xs  
   τred1gr uf P t h ({V:Ty=v; e}, xs) ({V:Ty=None; e'}, xs')"
by(blast intro: converse_rtranclp_into_rtranclp Block1Some τmove1BlockSome Block_None_τred1r_xt)

lemma Sync_τred1r_xt:
  "τred1gr uf P t h (e, xs) (e', xs')  τred1gr uf P t h (syncV (e) e2, xs) (syncV (e') e2, xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl Synchronized1Red1 τmove1Sync)

lemma InSync_τred1r_xt:
  "τred1gr uf P t h (e, xs) (e', xs')  τred1gr uf P t h (insyncV (a) e, xs) (insyncV (a) e', xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl Synchronized1Red2 τmove1InSync)

lemma Seq_τred1r_xt:
  "τred1gr uf P t h (e, xs) (e', xs')  τred1gr uf P t h (e;;e2, xs) (e';;e2, xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl Seq1Red τmove1Seq)

lemma Cond_τred1r_xt:
  "τred1gr uf P t h (e, xs) (e', xs')  τred1gr uf P t h (if (e) e1 else e2, xs) (if (e') e1 else e2, xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl Cond1Red τmove1Cond)

lemma Throw_τred1r_xt:
  "τred1gr uf P t h (e, xs) (e', xs')  τred1gr uf P t h (throw e, xs) (throw e', xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl Throw1Red τmove1Throw)

lemma Try_τred1r_xt:
  "τred1gr uf P t h (e, xs) (e', xs')  τred1gr uf P t h (try e catch(C V) e2, xs) (try e' catch(C V) e2, xs')"
by(induct rule: rtranclp_induct2)(auto intro: rtranclp.rtrancl_into_rtrancl Try1Red τmove1Try)

lemma τred1t_ThrowD [dest]: "τred1gt uf P t h (Throw a, xs) (e'', xs'')  e'' = Throw a  xs'' = xs"
by(induct rule: tranclp_induct2)(auto)

lemma τred1r_ThrowD [dest]: "τred1gr uf P t h (Throw a, xs) (e'', xs'')  e'' = Throw a  xs'' = xs"
by(induct rule: rtranclp_induct2)(auto)

lemma τRed1_conv [iff]:
  "τRed1g uf P t h (ex, exs) (ex', exs') = (uf,P,t ⊢1 ex/exs, h -ε ex'/exs', h  τMove1 P h (ex, exs))"
by(simp add: τRed1g_def)


lemma τred1t_into_τRed1t:
  "τred1gt uf P t h (e, xs) (e'', xs'')  τRed1gt uf P t h ((e, xs), exs) ((e'', xs''), exs)"
by(induct rule: tranclp_induct2)(fastforce dest: red1Red intro: τmove1Block tranclp.intros)+

lemma τred1r_into_τRed1r:
  "τred1gr uf P t h (e, xs) (e'', xs'')  τRed1gr uf P t h ((e, xs), exs) ((e'', xs''), exs)"
by(induct rule: rtranclp_induct2)(fastforce dest: red1Red intro: τmove1Block rtranclp.intros)+

lemma red1_max_vars: "uf,P,t ⊢1 e, s -ta e', s'  max_vars e'  max_vars e"
  and reds1_max_varss: "uf,P,t ⊢1 es, s [-ta→] es', s'  max_varss es'  max_varss es"
by(induct rule: red1_reds1.inducts) auto

lemma τred1t_max_vars: "τred1gt uf P t h (e, xs) (e', xs')  max_vars e'  max_vars e"
by(induct rule: tranclp_induct2)(auto dest: red1_max_vars)

lemma τred1r_max_vars: "τred1gr uf P t h (e, xs) (e', xs')  max_vars e'  max_vars e"
by(induct rule: rtranclp_induct2)(auto dest: red1_max_vars)

lemma τred1r_Val:
  "τred1gr uf P t h (Val v, xs) s'  s' = (Val v, xs)"
proof
  assume "τred1gr uf P t h (Val v, xs) s'"
  thus "s' = (Val v, xs)" by induct(auto)
qed auto

lemma τred1t_Val:
  "τred1gt uf P t h (Val v, xs) s'  False"
proof
  assume "τred1gt uf P t h (Val v, xs) s'"
  thus False by induct auto
qed auto

lemma τreds1r_map_Val:
  "τreds1gr uf P t h (map Val vs, xs) s'  s' = (map Val vs, xs)"
proof
  assume "τreds1gr uf P t h (map Val vs, xs) s'"
  thus "s' = (map Val vs, xs)" by induct auto
qed auto

lemma τreds1t_map_Val:
  "τreds1gt uf P t h (map Val vs, xs) s'  False"
proof
  assume "τreds1gt uf P t h (map Val vs, xs) s'"
  thus "False" by induct auto
qed auto

lemma τreds1r_map_Val_Throw:
  "τreds1gr uf P t h (map Val vs @ Throw a # es, xs) s'  s' = (map Val vs @ Throw a # es, xs)"
  (is "?lhs  ?rhs")
proof
  assume ?lhs thus ?rhs by induct auto
qed auto

lemma τreds1t_map_Val_Throw:
  "τreds1gt uf P t h (map Val vs @ Throw a # es, xs) s'  False"
  (is "?lhs  ?rhs")
proof
  assume ?lhs thus ?rhs by induct auto
qed auto

lemma τred1r_Throw:
  "τred1gr uf P t h (Throw a, xs) s'  s' = (Throw a, xs)" (is "?lhs  ?rhs")
proof
  assume ?lhs thus ?rhs by induct auto
qed simp

lemma τred1t_Throw:
  "τred1gt uf P t h (Throw a, xs) s'  False" (is "?lhs  ?rhs")
proof
  assume ?lhs thus ?rhs by induct auto
qed simp

lemma red1_False_into_red1_True:
  "False,P,t ⊢1 e, s -ta e', s'  True,P,t ⊢1 e, s -ta e', s'"
  and reds1_False_into_reds1_True:
  "False,P,t ⊢1 es, s [-ta→] es', s'  True,P,t ⊢1 es, s [-ta→] es', s'"
  by (induct rule: red1_reds1.inducts) (auto intro: red1_reds1.intros)

lemma Red1_False_into_Red1_True:
  assumes "False,P,t ⊢1 ex/exs,shr s -ta ex'/exs',m'"
  shows "True,P,t ⊢1 ex/exs,shr s -ta ex'/exs',m'"
using assms
by(cases)(auto dest: Red1.intros red1_False_into_red1_True)

lemma red1_Suspend_is_call:
  " uf,P,t ⊢1 e, s -ta e', s'; Suspend w  set taw   call1 e'  None"
  and reds_Suspend_is_calls:
  " uf,P,t ⊢1 es, s [-ta→] es', s'; Suspend w  set taw   calls1 es'  None"
by(induct rule: red1_reds1.inducts)(auto dest: red_external_Suspend_StaySame)

lemma Red1_Suspend_is_call:
  " uf,P,t ⊢1 (e, xs)/exs, h -ta (e', xs')/exs', h'; Suspend w  set taw   call1 e'  None"
by(auto elim!: Red1.cases dest: red1_Suspend_is_call)

lemma Red1_mthr: "multithreaded final_expr1 (mred1g uf P)"
by(unfold_locales)(fastforce elim!: Red1.cases dest: red1_new_thread_heap)+

lemma red1_τmove1_heap_unchanged: " uf,P,t ⊢1 e, s -ta e', s'; τmove1 P (hp s) e   hp s' = hp s"
  and red1_τmoves1_heap_unchanged: " uf,P,t ⊢1 es, s [-ta→] es', s'; τmoves1 P (hp s) es   hp s' = hp s"
apply(induct rule: red1_reds1.inducts)
apply(fastforce simp add: map_eq_append_conv τexternal'_def τexternal_def dest: τexternal'_red_external_heap_unchanged)+
done

lemma Red1_τmthr_wf: "τmultithreaded_wf final_expr1 (mred1g uf P) (τMOVE1 P)"
proof -
  interpret multithreaded final_expr1 "mred1g uf P" convert_RA
    by(rule Red1_mthr)
  show ?thesis
  proof
    fix x1 m1 t ta1 x1' m1'
    assume "mred1g uf P t (x1, m1) ta1 (x1', m1')" "τMOVE1 P (x1, m1) ta1 (x1', m1')"
    thus "m1 = m1'" by(cases x1)(fastforce elim!: Red1.cases dest: red1_τmove1_heap_unchanged)
  next
    fix s ta s'
    assume "τMOVE1 P s ta s'"
    thus "ta = ε" by(simp add: split_beta)
  qed
qed

end

sublocale J1_heap_base < Red1_mthr: 
  τmultithreaded_wf 
    final_expr1
    "mred1g uf P"
    convert_RA
    "τMOVE1 P"
  for uf P
by(rule Red1_τmthr_wf)

context J1_heap_base begin

lemma τRed1't_into_Red1'_τmthr_silent_movet:
  "τRed1gt uf P t h (ex2, exs2) (ex2'', exs2'')
   Red1_mthr.silent_movet uf P t ((ex2, exs2), h) ((ex2'', exs2''), h)"
apply(induct rule: tranclp_induct2)
 apply clarsimp
 apply(rule tranclp.r_into_trancl)
 apply(simp add: Red1_mthr.silent_move_iff)
apply(erule tranclp.trancl_into_trancl)
apply(simp add: Red1_mthr.silent_move_iff)
done

lemma τRed1t_into_Red1'_τmthr_silent_moves:
  "τRed1gt uf P t h (ex2, exs2) (ex2'', exs2'')
   Red1_mthr.silent_moves uf P t ((ex2, exs2), h) ((ex2'', exs2''), h)"
by(rule tranclp_into_rtranclp)(rule τRed1't_into_Red1'_τmthr_silent_movet)

lemma τRed1'r_into_Red1'_τmthr_silent_moves:
  "τRed1gr uf P t h (ex, exs) (ex', exs')  Red1_mthr.silent_moves uf P t ((ex, exs), h) ((ex', exs'), h)"
apply(induct rule: rtranclp_induct2)
 apply blast
apply(erule rtranclp.rtrancl_into_rtrancl)
apply(simp add: Red1_mthr.silent_move_iff)
done

lemma τRed1r_rtranclpD:
  "τRed1gr uf P t h s s'  τtrsys.silent_moves (mred1g uf P t) (τMOVE1 P) (s, h) (s', h)"
apply(induct rule: rtranclp_induct)
apply(auto elim!: rtranclp.rtrancl_into_rtrancl intro: τtrsys.silent_move.intros)
done

lemma τRed1t_tranclpD:
  "τRed1gt uf P t h s s'  τtrsys.silent_movet (mred1g uf P t) (τMOVE1 P) (s, h) (s', h)"
apply(induct rule: tranclp_induct)
apply(rule tranclp.r_into_trancl)
apply(auto elim!: tranclp.trancl_into_trancl intro!: τtrsys.silent_move.intros simp: τRed1g_def split_def)
done

lemma τmreds1_Val_Nil: "τtrsys.silent_moves (mred1g uf P t) (τMOVE1 P) (((Val v, xs), []), h) s  s = (((Val v, xs), []), h)"
proof
  assume "τtrsys.silent_moves (mred1g uf P t) (τMOVE1 P) (((Val v, xs), []), h) s"
  thus "s = (((Val v, xs), []), h)"
    by induct(auto elim!: Red1_mthr.silent_move.cases Red1.cases)
qed auto

lemma τmreds1_Throw_Nil:
  "τtrsys.silent_moves (mred1g uf P t) (τMOVE1 P) (((Throw a, xs), []), h) s  s = (((Throw a, xs), []), h)"
proof
  assume "τtrsys.silent_moves (mred1g uf P t) (τMOVE1 P) (((Throw a, xs), []), h) s"
  thus "s = (((Throw a, xs), []), h)"
    by induct(auto elim!: Red1_mthr.silent_move.cases Red1.cases)
qed auto

end

end

Theory J1Deadlock

(*  Title:      JinjaThreads/Compiler/J1Deadlock.thy
    Author:     Andreas Lochbihler
*)

section ‹Deadlock perservation for the intermediate language›

theory J1Deadlock imports
  J1
  "../Framework/FWDeadlock"
  "../Common/ExternalCallWF"
begin

context J1_heap_base begin

lemma IUF_red_taD:
  "True,P,t ⊢1 e, s -ta e', s'
   e' ta' s'. False,P,t ⊢1 e, s -ta' e', s' 
     collect_locks ta'l  collect_locks tal  set ta'c  set tac  collect_interrupts ta'i  collect_interrupts tai 
     (s. Red1_mthr.actions_ok s t ta')"

  and IUFs_reds_taD:
  "True,P,t ⊢1 es, s [-ta→] es', s'
   es' ta' s'. False,P,t ⊢1 es, s [-ta'→] es', s' 
     collect_locks ta'l  collect_locks tal  set ta'c  set tac  collect_interrupts ta'i  collect_interrupts tai 
     (s. Red1_mthr.actions_ok s t ta')"
proof(induct rule: red1_reds1.inducts)
  case Red1InstanceOf thus ?case
    using [[hypsubst_thin = true]]
    by(auto intro!: exI red1_reds1.Red1InstanceOf simp del: split_paired_Ex)((subst fst_conv snd_conv wset_def)+, simp)
next
  case Red1CallExternal thus ?case
    by(fastforce simp del: split_paired_Ex dest: red_external_ta_satisfiable[where final="final_expr1 :: ('addr expr1 × 'addr val list) × ('addr expr1 × 'addr val list) list  bool"] intro: red1_reds1.Red1CallExternal)
next
  case Lock1Synchronized thus ?case
    by(auto intro!: exI exI[where x="(K$ None, (Map.empty, undefined), Map.empty, {})"] red1_reds1.Lock1Synchronized simp del: split_paired_Ex simp add: lock_ok_las_def finfun_upd_apply may_lock.intros(1))
next
  case (Synchronized1Red2 e s ta e' s' V a)
  then obtain e' ta' s'
    where "False,P,t ⊢1 e,s -ta' e',s'"
    and L: "collect_locks ta'l  collect_locks tal  set ta'c  set tac  collect_interrupts ta'i  collect_interrupts tai"
    and aok: "s. Red1_mthr.actions_ok s t ta'"
    by blast
  from ‹False,P,t ⊢1 e,s -ta' e',s' have "False,P,t ⊢1 insyncV (a) e, s -ta' insyncV (a) e', s'"
    by(rule red1_reds1.Synchronized1Red2)
  thus ?case using L aok by blast
next
  case Unlock1Synchronized thus ?case
    by(auto simp del: split_paired_Ex intro!: exI exI[where x="(K$ (t, 0), (Map.empty, undefined), Map.empty, {})"] red1_reds1.Unlock1Synchronized simp add: lock_ok_las_def finfun_upd_apply)
next
  case Unlock1SynchronizedFail thus ?case
    by(auto simp del: split_paired_Ex intro!: exI exI[where x="(K$ (t, 0), (Map.empty, undefined), Map.empty, {})"] red1_reds1.Unlock1Synchronized simp add: lock_ok_las_def finfun_upd_apply collect_locks_def split: if_split_asm)
next
  case Synchronized1Throw2 thus ?case
    by(auto simp del: split_paired_Ex intro!: exI exI[where x="(K$ (t, 0), (Map.empty, undefined), Map.empty, {})"] red1_reds1.Synchronized1Throw2 simp add: lock_ok_las_def finfun_upd_apply)
next
  case Synchronized1Throw2Fail thus ?case
    by(auto simp del: split_paired_Ex intro!: exI exI[where x="(K$ (t, 0), (Map.empty, undefined), Map.empty, {})"] red1_reds1.Synchronized1Throw2 simp add: lock_ok_las_def finfun_upd_apply collect_locks_def split: if_split_asm)
qed(fastforce intro: red1_reds1.intros)+

lemma IUF_Red1_taD:
  assumes "True,P,t ⊢1 ex/exs, h -ta ex'/exs', h'"
  shows "ex' exs' h' ta'. False,P,t ⊢1 ex/exs, h -ta' ex'/exs', h' 
     collect_locks ta'l  collect_locks tal  set ta'c  set tac  collect_interrupts ta'i  collect_interrupts tai 
     (s. Red1_mthr.actions_ok s t ta')"
using assms
apply(cases)
apply(safe dest!: IUF_red_taD)
  apply(simp del: split_paired_Ex)
  apply(rule exI conjI)+
  apply(erule red1Red)
  apply simp
  apply blast
 apply(rule exI conjI red1Call)+
 apply(auto simp add: lock_ok_las_def)
apply(rule exI conjI red1Return)+
apply auto
done

lemma mred1'_mred1_must_sync_eq:
  "Red1_mthr.must_sync False P t x (shr s) = Red1_mthr.must_sync True P t x (shr s)"
proof
  assume "Red1_mthr.must_sync False P t x (shr s)"
  thus "Red1_mthr.must_sync True P t x (shr s)"
    by(rule Red1_mthr.must_syncE)(rule Red1_mthr.must_syncI, auto simp add: split_def simp del: split_paired_Ex intro: Red1_False_into_Red1_True)
next
  assume "Red1_mthr.must_sync True P t x (shr s)"
  thus "Red1_mthr.must_sync False P t x (shr s)"
    apply(rule Red1_mthr.must_syncE)
    apply(rule Red1_mthr.must_syncI)
    apply(cases x)
    apply(auto simp add: split_beta split_paired_Ex)
    apply(drule IUF_Red1_taD)
    apply simp
    apply blast
    done
qed

lemma Red1_Red1'_deadlock_inv:
  "Red1_mthr.deadlock True P s = Red1_mthr.deadlock False P s"
proof(rule iffI)
  assume dead: "Red1_mthr.deadlock True P s"
  show "Red1_mthr.deadlock False P s"
  proof(rule multithreaded_base.deadlockI)
    fix t x
    assume tst: "thr s t = (x, no_wait_locks)"
      and nfin: "¬ final_expr1 x"
      and wst: "wset s t = None"
    with dead obtain ms: "Red1_mthr.must_sync True P t x (shr s)"
      and cs [rule_format]: "LT. Red1_mthr.can_sync True P t x (shr s) LT 
               (ltLT. final_thread.must_wait final_expr1 s t lt (dom (thr s)))"
      by(rule Red1_mthr.deadlockD1)
    from ms[folded mred1'_mred1_must_sync_eq]
    show "Red1_mthr.must_sync False P t x (shr s) 
             (LT. Red1_mthr.can_sync False P t x (shr s) LT 
                   (ltLT. final_thread.must_wait final_expr1 s t lt (dom (thr s))))"
    proof
      show "LT. Red1_mthr.can_sync False P t x (shr s) LT 
         (ltLT. final_thread.must_wait final_expr1 s t lt (dom (thr s)))"
      proof(intro strip)
        fix LT
        assume "Red1_mthr.can_sync False P t x (shr s) LT"
        then obtain ta x' m' where "mred1' P t (x, shr s) ta (x', m')" 
          and [simp]: "LT = collect_locks tal <+> collect_cond_actions tac <+> collect_interrupts tai"
          by(rule Red1_mthr.can_syncE)
        hence "mred1 P t (x, shr s) ta (x', m')" by(auto simp add: split_beta intro: Red1_False_into_Red1_True)
        hence "Red1_mthr.can_sync True P t x (shr s) LT" by(rule Red1_mthr.can_syncI) simp
        thus "ltLT. final_thread.must_wait final_expr1 s t lt (dom (thr s))" by(rule cs)
      qed
    qed
  next
    fix t x ln l
    assume "thr s t = (x, ln)" "0 < ln $ l" "¬ waiting (wset s t)"
    thus "l t'. 0 < ln $ l  t  t'  thr s t'  None  has_lock ((locks s) $ l) t'"
      by(rule Red1_mthr.deadlockD2[OF dead]) blast
  next
    fix t x w
    assume "thr s t = (x, no_wait_locks)"
    thus "wset s t  PostWS w"
      by(rule Red1_mthr.deadlockD3[OF dead, rule_format])
  qed
next
  assume dead: "Red1_mthr.deadlock False P s"
  show "Red1_mthr.deadlock True P s"
  proof(rule Red1_mthr.deadlockI)
    fix t x
    assume tst: "thr s t = (x, no_wait_locks)"
      and nfin: "¬ final_expr1 x"
      and wst: "wset s t = None"
    with dead obtain ms: "Red1_mthr.must_sync False P t x (shr s)"
      and cs [rule_format]: "LT. Red1_mthr.can_sync False P t x (shr s) LT 
               (ltLT. final_thread.must_wait final_expr1 s t lt (dom (thr s)))"
      by(rule Red1_mthr.deadlockD1)
    from ms[unfolded mred1'_mred1_must_sync_eq]
    show "Red1_mthr.must_sync True P t x (shr s) 
             (LT. Red1_mthr.can_sync True P t x (shr s) LT 
                   (ltLT. final_thread.must_wait final_expr1 s t lt (dom (thr s))))"
    proof
      show "LT. Red1_mthr.can_sync True P t x (shr s) LT 
         (ltLT. final_thread.must_wait final_expr1 s t lt (dom (thr s)))"
      proof(intro strip)
        fix LT
        assume "Red1_mthr.can_sync True P t x (shr s) LT"
        then obtain ta x' m' where "mred1 P t (x, shr s) ta (x', m')" 
          and [simp]: "LT = collect_locks tal <+> collect_cond_actions tac <+> collect_interrupts tai"
          by(rule Red1_mthr.can_syncE)
        then obtain e xs exs e' xs' exs' where x [simp]: "x = ((e, xs), exs)" "x' = ((e', xs'), exs')"
          and red: "True,P,t ⊢1 (e, xs)/exs, shr s -ta (e', xs')/exs', m'" by(cases x, cases x') fastforce
        from IUF_Red1_taD[OF red] obtain ex'' exs'' h'' ta' 
          where red': "False,P,t ⊢1 (e, xs)/exs,shr s -ta' ex''/exs'',h''"
          and "collect_locks ta'l <+> collect_cond_actions ta'c <+> collect_interrupts ta'i  collect_locks tal <+> collect_cond_actions tac <+> collect_interrupts tai"
          by auto blast
        then obtain LT' where cs': "Red1_mthr.can_sync False P t x (shr s) LT'" 
          and LT': "LT'  LT" by(cases ex'')(fastforce intro!: Red1_mthr.can_syncI)
        with cs[of LT'] show "ltLT. final_thread.must_wait final_expr1 s t lt (dom (thr s))" by auto
      qed
    qed
  next
    fix t x ln l
    assume "thr s t = (x, ln)" "0 < ln $ l" "¬ waiting (wset s t)"
    thus "l t'. 0 < ln $ l  t  t'  thr s t'  None  has_lock ((locks s) $ l) t'"
      by(rule Red1_mthr.deadlockD2[OF dead]) blast
  next
    fix t x w
    assume "thr s t = (x, no_wait_locks)"
    thus "wset s t  PostWS w"
      by(rule Red1_mthr.deadlockD3[OF dead, rule_format])
  qed
qed

end

end

Theory PCompiler

(*  Title:      JinjaThread/Compiler/PCompiler.thy
    Author:     Tobias Nipkow, Andreas Lochbihler
*)

section ‹Program Compilation›

theory PCompiler
imports
  "../Common/WellForm"
  "../Common/BinOp"
  "../Common/Conform"
begin

definition compM :: "(mname  ty list  ty  'a  'b)  'a mdecl'  'b mdecl'"
where "compM f  λ(M, Ts, T, m). (M, Ts, T, map_option (f M Ts T) m)"

definition compC :: "(cname  mname  ty list  ty  'a  'b)  'a cdecl  'b cdecl"
where "compC f    λ(C,D,Fdecls,Mdecls). (C,D,Fdecls, map (compM (f C)) Mdecls)"

primrec compP :: "(cname  mname  ty list  ty  'a  'b)  'a prog  'b prog"
where "compP f (Program P) = Program (map (compC f) P)"

text‹Compilation preserves the program structure.  Therfore lookup
functions either commute with compilation (like method lookup) or are
preserved by it (like the subclass relation).›

lemma map_of_map4:
  "map_of (map (λ(x,a,b,c).(x,a,b,f x a b c)) ts) =
  (λx. map_option (λ(a,b,c).(a,b,f x a b c)) (map_of ts x))"
apply(induct ts)
 apply simp
apply(rule ext)
apply fastforce
done

lemma class_compP:
  "class P C = Some (D, fs, ms)
   class (compP f P) C = Some (D, fs, map (compM (f C)) ms)"
by(cases P)(simp add:class_def compP_def compC_def map_of_map4)

lemma class_compPD:
  "class (compP f P) C = Some (D, fs, cms)
   ms. class P C = Some(D,fs,ms)  cms = map (compM (f C)) ms"
by(cases P)(clarsimp simp add:class_def compP_def compC_def map_of_map4)


lemma [simp]: "is_class (compP f P) C = is_class P C"
(*<*)by(auto simp:is_class_def dest: class_compP class_compPD)(*>*)


lemma [simp]: "class (compP f P) C = map_option (λc. snd(compC f (C,c))) (class P C)"
(*<*)
apply(cases P)
apply(simp add:compC_def class_def map_of_map4)
apply(simp add:split_def)
done
(*>*)

lemma sees_methods_compP:
  "P  C sees_methods Mm 
  compP f P  C sees_methods (λM. map_option (λ((Ts,T,m),D). ((Ts,T,map_option (f D M Ts T) m),D)) (Mm M))"
(*<*)
apply(erule Methods.induct)
 apply(rule sees_methods_Object)
  apply(erule class_compP)
 apply(rule ext)
 apply(simp add:compM_def map_of_map4 option.map_comp)
 apply(case_tac "map_of ms M")
  apply simp
 apply fastforce
apply(rule sees_methods_rec)
   apply(erule class_compP)
  apply assumption
 apply assumption
apply(rule ext)
apply(simp add:map_add_def compM_def map_of_map4 option.map_comp split:option.split)
done
(*>*)


lemma sees_method_compP:
  "P  C sees M: TsT = m in D 
  compP f P  C sees M: TsT = map_option (f D M Ts T) m in D"
(*<*)by(fastforce elim:sees_methods_compP simp add:Method_def)(*>*)


lemma [simp]:
  "P  C sees M: TsT = m in D 
  method (compP f P) C M = (D,Ts,T,map_option (f D M Ts T) m)"
(*<*)
apply(drule sees_method_compP)
apply(simp add:method_def)
apply(rule the_equality)
 apply simp
apply(fastforce dest:sees_method_fun)
done
(*>*)


lemma sees_methods_compPD:
  " cP  C sees_methods Mm'; cP = compP f P  
  Mm. P  C sees_methods Mm 
        Mm' = (λM. map_option (λ((Ts,T,m),D). ((Ts,T,map_option (f D M Ts T) m),D)) (Mm M))"
(*<*)
apply(erule Methods.induct)
 apply(clarsimp simp:compC_def)
 apply(rule exI)
 apply(rule conjI, erule sees_methods_Object)
 apply(rule refl)
 apply(rule ext)
 apply(simp add:compM_def map_of_map4 option.map_comp)
 apply(case_tac "map_of b M")
  apply simp
 apply fastforce
apply(clarsimp simp:compC_def)
apply(rule exI, rule conjI)
apply(erule (2) sees_methods_rec)
 apply(rule refl)
apply(rule ext)
apply(simp add:map_add_def compM_def map_of_map4 option.map_comp split:option.split)
done
(*>*)


lemma sees_method_compPD:
  "compP f P  C sees M: TsT = fm in D 
  m. P  C sees M: TsT = m in D  map_option (f D M Ts T) m = fm"
(*<*)
apply(simp add:Method_def)
apply clarify
apply(drule sees_methods_compPD[OF _ refl])
apply clarsimp
apply blast
done
(*>*)

lemma sees_method_native_compP [simp]:
  "compP f P  C sees M:Ts  T = Native in D  P  C sees M:Ts  T = Native in D"
by(auto dest: sees_method_compPD sees_method_compP)

lemma [simp]: "subcls1(compP f P) = subcls1 P"
by(fastforce simp add: is_class_def compC_def intro:subcls1I order_antisym dest:subcls1D)

lemma [simp]: "is_type (compP f P) T = is_type P T"
by(induct T)(auto cong: ty.case_cong)

lemma is_type_compP [simp]: "is_type (compP f P) = is_type P"
by auto

lemma compP_widen[simp]:
  "(compP f P  T  T') = (P  T  T')"
by(induct T' arbitrary: T)(simp_all add: widen_Class widen_Array)

lemma [simp]: "(compP f P  Ts [≤] Ts') = (P  Ts [≤] Ts')"
(*<*)
apply(induct Ts)
 apply simp
apply(cases Ts')
apply(auto simp:fun_of_def)
done
(*>*)

lemma is_lub_compP [simp]:
  "is_lub (compP f P) = is_lub P"
by(auto intro!: ext elim!: is_lub.cases intro: is_lub.intros)

lemma [simp]:
  fixes f :: "cname  mname  ty list  ty  'a  'b"
  shows "(compP f P  C has_fields FDTs) = (P  C has_fields FDTs)"
(*<*)
 (is "?A = ?B")
proof
  { fix cP::"'b prog" assume "cP  C has_fields FDTs"
    hence "cP = compP f P  P  C has_fields FDTs"
    proof induct
      case has_fields_Object
      thus ?case by(fast intro:Fields.has_fields_Object dest:class_compPD)
    next
      case has_fields_rec
      thus ?case by(fast intro:Fields.has_fields_rec dest:class_compPD)
    qed
  } note lem = this
  assume ?A
  with lem show ?B by blast
next
  assume ?B
  thus ?A
  proof induct
    case has_fields_Object
    thus ?case by(fast intro:Fields.has_fields_Object class_compP)
  next
    case has_fields_rec
    thus ?case by(fast intro:Fields.has_fields_rec class_compP)
  qed
qed
(*>*)


lemma [simp]: "fields (compP f P) C = fields P C"
(*<*)by(simp add:fields_def)(*>*)


lemma [simp]: "(compP f P  C sees F:T (fm) in D) = (P  C sees F:T (fm) in D)"
(*<*)by(simp add:sees_field_def)(*>*)


lemma [simp]: "field (compP f P) F D = field P F D"
(*<*)by(simp add:field_def)(*>*)


subsection‹Invariance of @{term wf_prog} under compilation›

lemma [iff]: "distinct_fst (classes (compP f P)) = distinct_fst (classes P)"
(*<*)
apply(cases P)
apply(simp add:distinct_fst_def compP_def compC_def)
apply(rename_tac list)
apply(induct_tac list)
apply (auto simp:image_iff)
done
(*>*)


lemma [iff]: "distinct_fst (map (compM f) ms) = distinct_fst ms"
(*<*)
apply(simp add:distinct_fst_def compM_def)
apply(induct ms)
apply (auto simp:image_iff)
done
(*>*)


lemma [iff]: "wf_syscls (compP f P) = wf_syscls P"
unfolding wf_syscls_def by auto

lemma [iff]: "wf_fdecl (compP f P) = wf_fdecl P"
(*<*)by(simp add:wf_fdecl_def)(*>*)


lemma set_compP:
 "(class (compP f P) C = (D,fs,ms'))  
  (ms. class P C = (D,fs,ms)  ms' = map (compM (f C)) ms)"
by(cases P)(auto simp add: compC_def image_iff map_of_map4)

lemma compP_has_method: "compP f P  C has M  P  C has M"
unfolding has_method_def
by(fastforce dest: sees_method_compPD intro: sees_method_compP)

lemma is_native_compP [simp]: "is_native (compP f P) = is_native P"
by(auto simp add: fun_eq_iff is_native.simps)

lemma τexternal_compP [simp]:
  "τexternal (compP f P) = τexternal P"
by(auto intro!: ext simp add: τexternal_def)

context heap_base begin

lemma heap_clone_compP [simp]: 
  "heap_clone (compP f P) = heap_clone P"
by(intro ext)(auto elim!: heap_clone.cases intro: heap_clone.intros)

lemma red_external_compP [simp]:
  "compP f P,t  aM(vs), h -ta→ext va, h'  P,t  aM(vs), h -ta→ext va, h'"
by(auto elim!: red_external.cases intro: red_external.intros)

lemma τexternal'_compP [simp]:
  "τexternal' (compP f P) = τexternal' P"
by(simp add: τexternal'_def [abs_def])

end

lemma wf_overriding_compP [simp]: "wf_overriding (compP f P) D (compM (f C) m) = wf_overriding P D m"
by(cases m)(fastforce intro: sees_method_compP[where f=f] dest: sees_method_compPD[where f=f] simp add: compM_def)

lemma wf_cdecl_compPI:
  assumes wf1_imp_wf2: 
    "C M Ts T m.  wf_mdecl wf1 P C (M,Ts,T,m); P  C sees M:TsT = m in C 
     wf_mdecl wf2 (compP f P) C (M,Ts,T, f C M Ts T m)"
  and wfcP1: "C rest. class P C = rest  wf_cdecl wf1 P (C, rest)"
  and xcomp: "class (compP f P) C = rest'"
  and wf: "wf_prog p P"
  shows "wf_cdecl wf2 (compP f P) (C, rest')"
proof -
  obtain D fs ms' where x: "rest' = (D, fs, ms')" by(cases rest')
  with xcomp obtain ms where xsrc: "class P C = (D,fs,ms)"
    and ms': "ms' = map (compM (f C)) ms"
    by(auto simp add: set_compP compC_def)
  from xsrc wfcP1 have wf1: "wf_cdecl wf1 P (C,D,fs,ms)" by blast
  { fix field
    assume "field  set fs"
    with wf1 have "wf_fdecl (compP f P) field" by(simp add: wf_cdecl_def) 
  }
  moreover from wf1 have "distinct_fst fs" by(simp add: wf_cdecl_def)
  moreover
  { fix m
    assume mset': "m  set ms'"
    obtain M Ts' T' body' where m: "m = (M, Ts', T', body')" by(cases m)
    with ms' obtain body where mf: "body' = map_option (f C M Ts' T') body"
      and mset: "(M, Ts', T', body)  set ms" using mset'
      by(clarsimp simp add: image_iff compM_def)
    moreover from mset xsrc wfcP1 have "wf_mdecl wf1 P C (M,Ts',T',body)"
      by(fastforce simp add: wf_cdecl_def)
    moreover from wf xsrc mset x have "P  C sees M:Ts'T' = body in C"
      by(auto intro: mdecl_visible)
    ultimately have "wf_mdecl wf2 (compP f P) C m" using m
      by(cases body)(simp add: wf_mdecl_def, auto intro: wf1_imp_wf2) }
  moreover from wf1 have "distinct_fst ms" by(simp add: wf_cdecl_def)
  with ms' have "distinct_fst ms'" by(auto)
  moreover
  { assume CObj: "C  Object"
    with xsrc wfcP1
    have part1: "is_class (compP f P) D" "¬ compP f P  D * C"
      by(auto simp add: wf_cdecl_def)
    { fix m
      assume mset': "m  set ms'"
      obtain M Ts T body' where m: "m = (M, Ts, T, body')" by(cases m)
      with mset' ms' obtain body where mf: "body' = map_option (f C M Ts T) body"
        and mset: "(M, Ts, T, body)  set ms"
        by(clarsimp simp add: image_iff compM_def)
      from wf1 CObj mset
      have "wf_overriding P D (M, Ts, T, body)" by(auto simp add: wf_cdecl_def simp del: wf_overriding.simps)
      hence "wf_overriding (compP f P) D m" unfolding m mf
        by(subst (asm) wf_overriding_compP[symmetric, where f=f and C=C])(simp del: wf_overriding.simps wf_overriding_compP add: compM_def) }
    note this part1 }
  moreover
  { assume "C = Thread"
    with wf1 ms' have "m. (run, [], Void, m)  set ms'"
      by(fastforce simp add: wf_cdecl_def image_iff compM_def)+ }
  ultimately show ?thesis unfolding x wf_cdecl_def by blast
qed

lemma wf_prog_compPI:
assumes lift: 
  "C M Ts T m. 
     P  C sees M:TsT = m in C; wf_mdecl wf1 P C (M,Ts,T,m) 
     wf_mdecl wf2 (compP f P) C (M,Ts,T, f C M Ts T m)"
and wf: "wf_prog wf1 P"
shows "wf_prog wf2 (compP f P)"
using wf
apply (clarsimp simp add:wf_prog_def2)
apply(rule wf_cdecl_compPI[OF lift], assumption+)
apply(auto intro: wf)
done

lemma wf_cdecl_compPD:
  assumes wf1_imp_wf2: 
    "C M Ts T m.  wf_mdecl wf1 (compP f P) C (M,Ts,T,f C M Ts T m); compP f P  C sees M:TsT = f C M Ts T m in C 
     wf_mdecl wf2 P C (M,Ts,T, m)"
  and wfcP1: "C rest. class (compP f P) C = rest  wf_cdecl wf1 (compP f P) (C, rest)"
  and xcomp: "class P C = rest"
  and wf: "wf_prog wf_md (compP f P)"
  shows "wf_cdecl wf2 P (C, rest)"
proof -
  obtain D fs ms' where x: "rest = (D, fs, ms')" by(cases rest)
  with xcomp have xsrc: "class (compP f P) C = (D,fs,map (compM (f C)) ms')"
    by(auto simp add: set_compP compC_def)
  from xsrc wfcP1 have wf1: "wf_cdecl wf1 (compP f P) (C,D,fs,map (compM (f C)) ms')" by blast
  { fix field
    assume "field  set fs"
    with wf1 have "wf_fdecl P field" by(simp add: wf_cdecl_def) 
  }
  moreover from wf1 have "distinct_fst fs" by(simp add: wf_cdecl_def)
  moreover
  { fix m
    assume mset': "m  set ms'"
    obtain M Ts' T' body' where m: "m = (M, Ts', T', body')" by(cases m)
    hence mset: "(M, Ts', T', map_option (f C M Ts' T') body')  set (map (compM (f C)) ms')" using mset'
      by(auto simp add: image_iff compM_def intro: rev_bexI)
    moreover from wf xsrc mset x have "compP f P  C sees M:Ts'T' = map_option (f C M Ts' T') body' in C"
      by(auto intro: mdecl_visible)
    moreover from mset wfcP1[rule_format, OF xsrc]
    have "wf_mdecl wf1 (compP f P) C (M,Ts',T',map_option (f C M Ts' T') body')"
      by(auto simp add: wf_cdecl_def)
    ultimately have "wf_mdecl wf2 P C m" using m
      by(cases body')(simp add: wf_mdecl_def, auto intro: wf1_imp_wf2) }
  moreover from wf1 have "distinct_fst ms'" by(simp add: wf_cdecl_def)
  moreover
  { assume CObj: "C  Object"
    with xsrc wfcP1
    have part1: "is_class P D" "¬ P  D * C"
      by(auto simp add: wf_cdecl_def)
    { fix m
      assume mset': "m  set ms'"
      with wf1 CObj have "wf_overriding (compP f P) D (compM (f C) m)"
        by(simp add: wf_cdecl_def del: wf_overriding_compP)
      hence "wf_overriding P D m" by simp }
    note this part1 }
  moreover
  { assume "C = Thread"
    with wf1 have "m. (run, [], Void, m)  set ms'"
      by(fastforce simp add: wf_cdecl_def image_iff compM_def)+ }
  ultimately show ?thesis unfolding x wf_cdecl_def by blast
qed

lemma wf_prog_compPD:
assumes wf: "wf_prog wf1 (compP f P)"
and lift: 
  "C M Ts T m. 
     compP f P  C sees M:TsT = f C M Ts T m in C; wf_mdecl wf1 (compP f P) C (M,Ts,T, f C M Ts T m) 
     wf_mdecl wf2 P C (M,Ts,T,m)"
shows "wf_prog wf2 P"
using wf
apply(clarsimp simp add:wf_prog_def2)
apply(rule wf_cdecl_compPD[OF lift], assumption+) 
apply(auto intro: wf)
done

lemma WT_binop_compP [simp]: "compP f P  T1«bop»T2 :: T  P  T1«bop»T2 :: T"
by(cases bop)(fastforce)+

lemma WTrt_binop_compP [simp]: "compP f P  T1«bop»T2 : T  P  T1«bop»T2 : T"
by(cases bop)(fastforce)+

lemma binop_relevant_class_compP [simp]: "binop_relevant_class bop (compP f P) = binop_relevant_class bop P"
by(cases bop) simp_all

lemma is_class_compP [simp]:
  "is_class (compP f P) = is_class P"
by(simp add: is_class_def fun_eq_iff)

lemma has_field_compP [simp]:
  "compP f P  C has F:T (fm) in D  P  C has F:T (fm) in D"
by(auto simp add: has_field_def)

context heap_base begin

lemma compP_addr_loc_type [simp]:
  "addr_loc_type (compP f P) = addr_loc_type P"
by(auto elim!: addr_loc_type.cases intro: addr_loc_type.intros intro!: ext)

lemma conf_compP [simp]:
  "compP f P,h  v :≤ T  P,h  v :≤ T"
by(simp add: conf_def)

lemma compP_conf: "conf (compP f P) = conf P"
by(auto simp add: conf_def intro!: ext)

lemma compP_confs: "compP f P,h  vs [:≤] Ts  P,h  vs [:≤] Ts"
by(simp add: compP_conf)

lemma tconf_compP [simp]: "compP f P, h  t √t  P,h  t √t"
by(auto simp add: tconf_def)

lemma wf_start_state_compP [simp]:
  "wf_start_state (compP f P) = wf_start_state P"
by(auto 4 6 simp add: fun_eq_iff wf_start_state.simps compP_conf dest: sees_method_compP[where f=f] sees_method_compPD[where f=f])

end

lemma compP_addr_conv:
  "addr_conv addr2thread_id thread_id2addr typeof_addr (compP f P) = addr_conv addr2thread_id thread_id2addr typeof_addr P"
unfolding addr_conv_def
by simp

lemma compP_heap:
  "heap addr2thead_id thread_id2addr allocate typeof_addr heap_write (compP f P) =
  heap addr2thead_id thread_id2addr allocate typeof_addr heap_write P"
unfolding heap_def compP_addr_conv heap_axioms_def
by auto

lemma compP_heap_conf:
  "heap_conf addr2thead_id thread_id2addr empty_heap allocate typeof_addr heap_write hconf (compP f P) =
   heap_conf addr2thead_id thread_id2addr empty_heap allocate typeof_addr heap_write hconf P"
unfolding heap_conf_def heap_conf_axioms_def compP_heap
unfolding heap_base.compP_conf heap_base.compP_addr_loc_type is_type_compP is_class_compP
by(rule refl)

lemma compP_heap_conf_read:
  "heap_conf_read addr2thead_id thread_id2addr empty_heap allocate typeof_addr heap_read heap_write hconf (compP f P) =
   heap_conf_read addr2thead_id thread_id2addr empty_heap allocate typeof_addr heap_read heap_write hconf P"
unfolding heap_conf_read_def heap_conf_read_axioms_def
unfolding compP_heap_conf heap_base.compP_conf heap_base.compP_addr_loc_type 
by(rule refl)

text ‹compiler composition›

lemma compM_compM:
  "compM f (compM g md) = compM (λM Ts T. f M Ts T  g M Ts T) md"
by(cases md)(simp add: compM_def option.map_comp o_def)

lemma compC_compC:
  "compC f (compC g cd) = compC (λC M Ts T. f C M Ts T  g C M Ts T) cd"
by(simp add: compC_def split_beta compM_compM)

lemma compP_compP:
  "compP f (compP g P) = compP (λC M Ts T. f C M Ts T  g C M Ts T) P"
by(cases P)(simp add: compC_compC)

end

Theory Compiler2

(*  Title:      JinjaThreads/Compiler/Compiler2.thy
    Author:     Andreas Lochbihler, Tobias Nipkow
*)

section ‹Compilation Stage 2›

theory Compiler2
imports PCompiler J1State "../JVM/JVMInstructions"
begin

primrec compE2  :: "'addr expr1       'addr instr list"
  and compEs2 :: "'addr expr1 list  'addr instr list"
where
  "compE2 (new C) = [New C]"
| "compE2 (newA Te) = compE2 e @ [NewArray T]"
| "compE2 (Cast T e) = compE2 e @ [Checkcast T]"
| "compE2 (e instanceof T) = compE2 e @ [Instanceof T]"
| "compE2 (Val v) = [Push v]"
| "compE2 (e1 «bop» e2) = compE2 e1 @ compE2 e2 @ [BinOpInstr bop]"
| "compE2 (Var i) = [Load i]"
| "compE2 (i:=e) = compE2 e @ [Store i, Push Unit]"
| "compE2 (ai) = compE2 a @ compE2 i @ [ALoad]"
| "compE2 (ai := e) =  compE2 a @ compE2 i @ compE2 e @ [AStore, Push Unit]"
| "compE2 (a∙length) = compE2 a @ [ALength]"
| "compE2 (eF{D}) = compE2 e @ [Getfield F D]"
| "compE2 (e1F{D} := e2) = compE2 e1 @ compE2 e2 @ [Putfield F D, Push Unit]"
| "compE2 (e∙compareAndSwap(DF, e', e'')) = compE2 e @ compE2 e' @ compE2 e'' @ [CAS F D]"
| "compE2 (eM(es)) = compE2 e @ compEs2 es @ [Invoke M (size es)]"
| "compE2 ({i:T=vo; e}) = (case vo of None  [] | v  [Push v, Store i]) @ compE2 e"
| "compE2 (syncV (o') e) = compE2 o' @ [Dup, Store V, MEnter] @
                           compE2 e @ [Load V, MExit, Goto 4, Load V, MExit, ThrowExc]"
| "compE2 (insyncV (a) e) = [Goto 1]" ― ‹Define insync sensibly›
| "compE2 (e1;;e2) = compE2 e1 @ [Pop] @ compE2 e2"
| "compE2 (if (e) e1 else e2) =
          (let cnd   = compE2 e;
               thn   = compE2 e1;
               els   = compE2 e2;
               test  = IfFalse (int(size thn + 2)); 
               thnex = Goto (int(size els + 1))
           in cnd @ [test] @ thn @ [thnex] @ els)"
| "compE2 (while (e) c) =
          (let cnd   = compE2 e;
               bdy   = compE2 c;
               test  = IfFalse (int(size bdy + 3)); 
               loop  = Goto (-int(size bdy + size cnd + 2))
           in cnd @ [test] @ bdy @ [Pop] @ [loop] @ [Push Unit])"
| "compE2 (throw e) = compE2 e @ [ThrowExc]"
| "compE2 (try e1 catch(C i) e2) =
   (let catch = compE2 e2
    in compE2 e1 @ [Goto (int(size catch)+2), Store i] @ catch)"

| "compEs2 []     = []"
| "compEs2 (e#es) = compE2 e @ compEs2 es"


text‹Compilation of exception table. Is given start address of code
to compute absolute addresses necessary in exception table.›


fun compxE2  :: "'addr expr1       pc  nat  ex_table"
and compxEs2 :: "'addr expr1 list  pc  nat  ex_table"
where
  "compxE2 (new C) pc d = []"
| "compxE2 (newA Te) pc d = compxE2 e pc d"
| "compxE2 (Cast T e) pc d = compxE2 e pc d"
| "compxE2 (e instanceof T) pc d = compxE2 e pc d"
| "compxE2 (Val v) pc d = []"
| "compxE2 (e1 «bop» e2) pc d =
   compxE2 e1 pc d @ compxE2 e2 (pc + size(compE2 e1)) (d+1)"
| "compxE2 (Var i) pc d = []"
| "compxE2 (i:=e) pc d = compxE2 e pc d"
| "compxE2 (ai) pc d = compxE2 a pc d @ compxE2 i (pc + size (compE2 a)) (d + 1)"
| "compxE2 (ai := e) pc d =
         (let pc1 = pc  + size (compE2 a);
              pc2 = pc1 + size (compE2 i)
          in compxE2 a pc d @ compxE2 i pc1 (d + 1) @ compxE2 e pc2 (d + 2))"
| "compxE2 (a∙length) pc d = compxE2 a pc d"
| "compxE2 (eF{D}) pc d = compxE2 e pc d"
| "compxE2 (e1F{D} := e2) pc d = compxE2 e1 pc d @ compxE2 e2 (pc + size (compE2 e1)) (d + 1)"
| "compxE2 (e∙compareAndSwap(DF, e', e'')) pc d = 
   (let pc1 = pc  + size (compE2 e);
        pc2 = pc1 + size (compE2 e')
    in compxE2 e pc d @ compxE2 e' pc1 (d + 1) @ compxE2 e'' pc2 (d + 2))"
| "compxE2 (eM(es)) pc d = compxE2 e pc d @ compxEs2 es (pc + size(compE2 e)) (d+1)"
| "compxE2 ({i:T=vo; e}) pc d = compxE2 e (case vo of None  pc | v  Suc (Suc pc)) d"
| "compxE2 (syncV (o') e) pc d =
           (let pc1 = pc + size (compE2 o') + 3;
                pc2 = pc1 + size(compE2 e)
            in compxE2 o' pc d @ compxE2 e pc1 d @ [(pc1, pc2, None, Suc (Suc (Suc pc2)), d)])"
| "compxE2 (insyncV (a) e) pc d = []"
| "compxE2 (e1;;e2) pc d =
   compxE2 e1 pc d @ compxE2 e2 (pc+size(compE2 e1)+1) d"
| "compxE2 (if (e) e1 else e2) pc d =
           (let pc1   = pc + size(compE2 e) + 1;
                pc2   = pc1 + size(compE2 e1) + 1
            in compxE2 e pc d @ compxE2 e1 pc1 d @ compxE2 e2 pc2 d)"
| "compxE2 (while (b) e) pc d =
   compxE2 b pc d @ compxE2 e (pc+size(compE2 b)+1) d"
| "compxE2 (throw e) pc d = compxE2 e pc d"
| "compxE2 (try e1 catch(C i) e2) pc d =
   (let pc1 = pc + size(compE2 e1)
    in compxE2 e1 pc d @ compxE2 e2 (pc1+2) d @ [(pc,pc1,Some C,pc1+1,d)])"

| "compxEs2 [] pc d    = []"
| "compxEs2 (e#es) pc d = compxE2 e pc d @ compxEs2 es (pc+size(compE2 e)) (d+1)"

lemmas compxE2_compxEs2_induct =
  compxE2_compxEs2.induct[
    unfolded meta_all5_eq_conv meta_all4_eq_conv meta_all3_eq_conv meta_all2_eq_conv meta_all_eq_conv,
    case_names
      new NewArray Cast InstanceOf Val BinOp Var LAss AAcc AAss ALen FAcc FAss Call Block
      Synchronized InSynchronized Seq Cond While throw TryCatch
      Nil Cons]

lemma compE2_neq_Nil [simp]: "compE2 e  []"
by(induct e) auto

declare compE2_neq_Nil[symmetric, simp]

lemma compEs2_append [simp]: "compEs2 (es @ es') = compEs2 es @ compEs2 es'"
by(induct es) auto

lemma compEs2_eq_Nil_conv [simp]: "compEs2 es = []  es = []"
by(cases es) auto

lemma compEs2_map_Val: "compEs2 (map Val vs) = map Push vs"
by(induct vs) auto

lemma compE2_0th_neq_Invoke [simp]:
  "compE2 e ! 0  Invoke M n"
by(induct e)(auto simp add: nth_append)

declare compE2_0th_neq_Invoke[symmetric, simp]

lemma compxEs2_append [simp]:
  "compxEs2 (es @ es') pc d = compxEs2 es pc d @ compxEs2 es' (length (compEs2 es) + pc) (length es + d)"
by(induct es arbitrary: pc d)(auto simp add: ac_simps)

lemma compxEs2_map_Val [simp]: "compxEs2 (map Val vs) pc d = []"
by(induct vs arbitrary: d pc) auto

lemma compE2_blocks1 [simp]:
  "compE2 (blocks1 n Ts body) = compE2 body"
by(induct n Ts body rule: blocks1.induct)(auto)

lemma compxE2_blocks1 [simp]:
  "compxE2 (blocks1 n Ts body) = compxE2 body"
by(induct n Ts body rule: blocks1.induct)(auto intro!: ext)

lemma fixes e :: "'addr expr1" and es :: "'addr expr1 list"
  shows compE2_not_Return: "Return  set (compE2 e)"
  and compEs2_not_Return: "Return  set (compEs2 es)"
by(induct e and es rule: compE2.induct compEs2.induct)(auto)

primrec max_stack :: "'addr expr1  nat"
  and max_stacks :: "'addr expr1 list  nat"
where
  "max_stack (new C) = 1"
| "max_stack (newA Te) = max_stack e"
| "max_stack (Cast C e) = max_stack e"
| "max_stack (e instanceof T) = max_stack e"
| "max_stack (Val v) = 1"
| "max_stack (e1 «bop» e2) = max (max_stack e1) (max_stack e2) + 1"
| "max_stack (Var i) = 1"
| "max_stack (i:=e) = max_stack e"
| "max_stack (ai) = max (max_stack a) (max_stack i + 1)"
| "max_stack (ai := e) = max (max (max_stack a) (max_stack i + 1)) (max_stack e + 2)"
| "max_stack (a∙length) = max_stack a"
| "max_stack (eF{D}) = max_stack e"
| "max_stack (e1F{D} := e2) = max (max_stack e1) (max_stack e2) + 1"
| "max_stack (e∙compareAndSwap(DF, e', e'')) = max (max (max_stack e) (max_stack e' + 1)) (max_stack e'' + 2)"
| "max_stack (eM(es)) = max (max_stack e) (max_stacks es) + 1"
| "max_stack ({i:T=vo; e}) = max_stack e"
| "max_stack (syncV (o') e) = max (max_stack o') (max (max_stack e) 2)"
| "max_stack (insyncV (a) e) = 1"
| "max_stack (e1;;e2) = max (max_stack e1) (max_stack e2)"
| "max_stack (if (e) e1 else e2) =
   max (max_stack e) (max (max_stack e1) (max_stack e2))"
| "max_stack (while (e) c) = max (max_stack e) (max_stack c)"
| "max_stack (throw e) = max_stack e"
| "max_stack (try e1 catch(C i) e2) = max (max_stack e1) (max_stack e2)"

| "max_stacks [] = 0"
| "max_stacks (e#es) = max (max_stack e) (1 + max_stacks es)"

lemma max_stack1: "1  max_stack e"
(*<*)by(induct e) (simp_all add:max_def)(*>*)

lemma max_stacks_ge_length: "max_stacks es  length es"
by(induct es, auto)

lemma max_stack_blocks1 [simp]:
  "max_stack (blocks1 n Ts body) = max_stack body"
by(induct n Ts body rule: blocks1.induct) auto

definition compMb2 :: "'addr expr1  'addr jvm_method"
where
  "compMb2    λbody.
  let ins = compE2 body @ [Return];
      xt = compxE2 body 0 0
  in (max_stack body, max_vars body, ins, xt)"

definition compP2 :: "'addr J1_prog  'addr jvm_prog"
where "compP2    compP (λC M Ts T. compMb2)"

lemma compMb2:
  "compMb2 e = (max_stack e, max_vars e, (compE2 e @ [Return]), compxE2 e 0 0)"
by (simp add: compMb2_def)

end

Theory Exception_Tables

(*  Title:      JinjaThreads/Compiler/Exception_Tables.thy
    Author:     Andreas Lochbihler
*)

section ‹Various Operations for Exception Tables›

theory Exception_Tables imports
  Compiler2
  "../Common/ExternalCallWF"
  "../JVM/JVMExceptions"
begin

definition pcs :: "ex_table  nat set"
where "pcs xt    (f,t,C,h,d)  set xt. {f ..< t}"

lemma pcs_subset:
  fixes e :: "'addr expr1" and es :: "'addr expr1 list"
  shows "pcs(compxE2 e pc d)  {pc..<pc+size(compE2 e)}"
  and "pcs(compxEs2 es pc d)  {pc..<pc+size(compEs2 es)}" 
apply(induct e pc d and es pc d rule: compxE2_compxEs2_induct)
apply (simp_all add:pcs_def)
apply (fastforce)+
done

lemma pcs_Nil [simp]: "pcs [] = {}"
by(simp add:pcs_def)

lemma pcs_Cons [simp]: "pcs (x#xt) = {fst x ..< fst(snd x)}  pcs xt"
by(auto simp add: pcs_def)

lemma pcs_append [simp]: "pcs(xt1 @ xt2) = pcs xt1  pcs xt2"
by(simp add:pcs_def)

lemma [simp]: "pc < pc0  pc0+size(compE2 e)  pc  pc  pcs(compxE2 e pc0 d)"
using pcs_subset by fastforce

lemma [simp]: "pc < pc0  pc0+size(compEs2 es)  pc  pc  pcs(compxEs2 es pc0 d)"
using pcs_subset by fastforce

lemma [simp]: "pc1 + size(compE2 e1)  pc2  pcs(compxE2 e1 pc1 d1)  pcs(compxE2 e2 pc2 d2) = {}"
using pcs_subset by fastforce

lemma [simp]: "pc1 + size(compE2 e)  pc2  pcs(compxE2 e pc1 d1)  pcs(compxEs2 es pc2 d2) = {}"
using pcs_subset by fastforce

lemma match_ex_table_append_not_pcs [simp]:
 "pc  pcs xt0  match_ex_table P C pc (xt0 @ xt1) = match_ex_table P C pc xt1"
by (induct xt0) (auto simp: matches_ex_entry_def)

lemma outside_pcs_not_matches_entry [simp]:
  " x  set xt; pc  pcs xt   ¬ matches_ex_entry P D pc x"
by(auto simp:matches_ex_entry_def pcs_def)

lemma outside_pcs_compxE2_not_matches_entry [simp]:
  assumes xe: "xe  set(compxE2 e pc d)"
  and outside: "pc' < pc  pc+size(compE2 e)  pc'"
  shows "¬ matches_ex_entry P C pc' xe"
proof
  assume "matches_ex_entry P C pc' xe"
  with xe have "pc'  pcs(compxE2 e pc d)"
    by(force simp add:matches_ex_entry_def pcs_def)
  with outside show False by simp
qed

lemma outside_pcs_compxEs2_not_matches_entry [simp]:
  assumes xe: "xe  set(compxEs2 es pc d)" 
  and outside: "pc' < pc  pc+size(compEs2 es)  pc'"
  shows "¬ matches_ex_entry P C pc' xe"
proof
  assume "matches_ex_entry P C pc' xe"
  with xe have "pc'  pcs(compxEs2 es pc d)"
    by(force simp add:matches_ex_entry_def pcs_def)
  with outside show False by simp
qed

lemma match_ex_table_app[simp]:
  "xte  set xt1. ¬ matches_ex_entry P D pc xte 
  match_ex_table P D pc (xt1 @ xt) = match_ex_table P D pc xt"
by(induct xt1) simp_all

lemma match_ex_table_eq_NoneI [simp]:
  "x  set xtab. ¬ matches_ex_entry P C pc x 
  match_ex_table P C pc xtab = None"
using match_ex_table_app[where ?xt = "[]"] by fastforce

lemma match_ex_table_not_pcs_None:
  "pc  pcs xt  match_ex_table P C pc xt = None"
by(auto intro: match_ex_table_eq_NoneI)

lemma match_ex_entry:
  fixes start shows
  "matches_ex_entry P C pc (start, end, catch_type, handler) =
  (start  pc  pc < end  (case catch_type of None  True | C'  P  C * C'))"
by(simp add:matches_ex_entry_def)

lemma pcs_compxE2D [dest]:
  "pc  pcs (compxE2 e pc' d)  pc'  pc  pc < pc' + length (compE2 e)"
using pcs_subset by(fastforce)

lemma pcs_compxEs2D [dest]:
  "pc  pcs (compxEs2 es pc' d)  pc'  pc  pc < pc' + length (compEs2 es)"
using pcs_subset by(fastforce)

definition shift :: "nat  ex_table  ex_table"
where
  "shift n xt  map (λ(from,to,C,handler,depth). (n+from,n+to,C,n+handler,depth)) xt"

lemma shift_0 [simp]: "shift 0 xt = xt"
by(induct xt)(auto simp:shift_def)

lemma shift_Nil [simp]: "shift n [] = []"
by(simp add:shift_def)

lemma shift_Cons_tuple [simp]:
  "shift n ((from, to, C, handler, depth) # xt) = (from + n, to + n, C, handler + n, depth) # shift n xt"
by(simp add: shift_def)

lemma shift_append [simp]: "shift n (xt1 @ xt2) = shift n xt1 @ shift n xt2"
by(simp add:shift_def)

lemma shift_shift [simp]: "shift m (shift n xt) = shift (m+n) xt"
by(simp add: shift_def split_def)

lemma fixes e :: "'addr expr1" and es :: "'addr expr1 list"
  shows shift_compxE2: "shift pc (compxE2 e pc' d) = compxE2 e (pc' + pc) d"
  and  shift_compxEs2: "shift pc (compxEs2 es pc' d) = compxEs2 es (pc' + pc) d"
by(induct e and es arbitrary: pc pc' d and pc pc' d rule: compE2.induct compEs2.induct)
  (auto simp:shift_def ac_simps)

lemma compxE2_size_convs [simp]: "n  0  compxE2 e n d = shift n (compxE2 e 0 d)"
 and compxEs2_size_convs: "n  0  compxEs2 es n d = shift n (compxEs2 es 0 d)" 
by(simp_all add:shift_compxE2 shift_compxEs2)

lemma pcs_shift_conv [simp]: "pcs (shift n xt) = (+) n ` pcs xt"
apply(auto simp add: shift_def pcs_def)
apply(rule_tac x="x-n" in image_eqI)
apply(auto)
apply(rule bexI)
 prefer 2
 apply(assumption)
apply(auto)
done

lemma image_plus_const_conv [simp]:
  fixes m :: nat
  shows "m  (+) n ` A  m  n  m - n  A"
by(force)

lemma match_ex_table_shift_eq_None_conv [simp]:
  "match_ex_table P C pc (shift n xt) = None  pc < n  match_ex_table P C (pc - n) xt = None"
by(induct xt)(auto simp add: match_ex_entry split: if_split_asm)

lemma match_ex_table_shift_pc_None:
  "pc  n  match_ex_table P C pc (shift n xt) = None  match_ex_table P C (pc - n) xt = None"
by(simp add: match_ex_table_shift_eq_None_conv)

lemma match_ex_table_shift_eq_Some_conv [simp]:
  "match_ex_table P C pc (shift n xt) = (pc', d) 
   pc  n  pc'  n  match_ex_table P C (pc - n) xt = (pc' - n, d)"
by(induct xt)(auto simp add: match_ex_entry split: if_split_asm)

lemma match_ex_table_shift:
 "match_ex_table P C pc xt = (pc', d)  match_ex_table P C (n + pc) (shift n xt) = (n + pc', d)"
by(simp add: match_ex_table_shift_eq_Some_conv)

lemma match_ex_table_shift_pcD:
  "match_ex_table P C pc (shift n xt) = (pc', d)  pc  n  pc'  n  match_ex_table P C (pc - n) xt = (pc' - n, d)"
by(simp add: match_ex_table_shift_eq_Some_conv)

lemma match_ex_table_pcsD: "match_ex_table P C pc xt = (pc', D)  pc  pcs xt"
by(induct xt)(auto split: if_split_asm simp add: match_ex_entry)


definition stack_xlift :: "nat  ex_table  ex_table"
where "stack_xlift n xt  map (λ(from,to,C,handler,depth). (from, to, C, handler, n + depth)) xt"

lemma stack_xlift_0 [simp]: "stack_xlift 0 xt = xt"
by(induct xt, auto simp add: stack_xlift_def)

lemma stack_xlift_Nil [simp]: "stack_xlift n [] = []"
by(simp add: stack_xlift_def)

lemma stack_xlift_Cons_tuple [simp]:
  "stack_xlift n ((from, to, C, handler, depth) # xt) = (from, to, C, handler, depth + n) # stack_xlift n xt"
by(simp add: stack_xlift_def)

lemma stack_xlift_append [simp]: "stack_xlift n (xt @ xt') = stack_xlift n xt @ stack_xlift n xt'"
by(simp add: stack_xlift_def)

lemma stack_xlift_stack_xlift [simp]: "stack_xlift n (stack_xlift m xt) = stack_xlift (n + m) xt"
by(simp add: stack_xlift_def split_def)

lemma fixes e :: "'addr expr1" and es :: "'addr expr1 list"
  shows stack_xlift_compxE2: "stack_xlift n (compxE2 e pc d) = compxE2 e pc (n + d)"
  and stack_xlift_compxEs2: "stack_xlift n (compxEs2 es pc d) = compxEs2 es pc (n + d)"
by(induct e and es arbitrary: d pc and d pc rule: compE2.induct compEs2.induct)
  (auto simp add: shift_compxE2 simp del: compxE2_size_convs)

lemma compxE2_stack_xlift_convs [simp]: "d > 0  compxE2 e pc d = stack_xlift d (compxE2 e pc 0)"
  and compxEs2_stack_xlift_convs [simp]: "d > 0  compxEs2 es pc d = stack_xlift d (compxEs2 es pc 0)"
by(simp_all add: stack_xlift_compxE2 stack_xlift_compxEs2)

lemma stack_xlift_shift [simp]: "stack_xlift d (shift n xt) = shift n (stack_xlift d xt)"
by(induct xt)(auto)

lemma pcs_stack_xlift_conv [simp]: "pcs (stack_xlift n xt) = pcs xt"
by(auto simp add: pcs_def stack_xlift_def)

lemma match_ex_table_stack_xlift_eq_None_conv [simp]:
  "match_ex_table P C pc (stack_xlift d xt) = None  match_ex_table P C pc xt = None"
by(induct xt)(auto simp add: match_ex_entry)

lemma match_ex_table_stack_xlift_eq_Some_conv [simp]:
  "match_ex_table P C pc (stack_xlift n xt) = (pc', d)  d  n  match_ex_table P C pc xt = (pc', d - n)"
by(induct xt)(auto simp add: match_ex_entry)

lemma match_ex_table_stack_xliftD:
  "match_ex_table P C pc (stack_xlift n xt) = (pc', d)  d  n  match_ex_table P C pc xt = (pc', d - n)"
by(simp)

lemma match_ex_table_stack_xlift:
  "match_ex_table P C pc xt = (pc', d)  match_ex_table P C pc (stack_xlift n xt) = (pc', n + d)"
by simp

lemma pcs_stack_xlift: "pcs (stack_xlift n xt) = pcs xt"
by(auto simp add: stack_xlift_def pcs_def)

lemma match_ex_table_None_append [simp]:
  "match_ex_table P C pc xt = None
   match_ex_table P C pc (xt @ xt') = match_ex_table P C pc xt'"
by(induct xt, auto)

lemma match_ex_table_Some_append [simp]: 
  "match_ex_table P C pc xt = (pc', d)  match_ex_table P C pc (xt @ xt') = (pc', d)"
by(induct xt)(auto)

lemma match_ex_table_append:
  "match_ex_table P C pc (xt @ xt') = (case match_ex_table P C pc xt of None  match_ex_table P C pc xt' 
                                                                  | Some pcd  Some pcd)"
by(auto)

lemma match_ex_table_pc_length_compE2:
  "match_ex_table P a pc (compxE2 e pc' d) = pcd  pc'  pc  pc < length (compE2 e) + pc'"
  
  and match_ex_table_pc_length_compEs2:
  "match_ex_table P a pc (compxEs2 es pc' d) = pcd  pc'  pc  pc < length (compEs2 es) + pc'"
using pcs_subset by(cases pcd, fastforce dest!: match_ex_table_pcsD)+

lemma match_ex_table_compxE2_shift_conv:
  "f > 0  match_ex_table P C pc (compxE2 e f d) = (pc', d')  pc  f  pc'  f  match_ex_table P C (pc - f) (compxE2 e 0 d) = (pc' - f, d')"
by simp

lemma match_ex_table_compxEs2_shift_conv:
  "f > 0  match_ex_table P C pc (compxEs2 es f d) = (pc', d')  pc  f  pc'  f  match_ex_table P C (pc - f) (compxEs2 es 0 d) = (pc' - f, d')"
by(simp add: compxEs2_size_convs)

lemma match_ex_table_compxE2_stack_conv:
  "d > 0  match_ex_table P C pc (compxE2 e 0 d) = (pc', d')  d'  d  match_ex_table P C pc (compxE2 e 0 0) = (pc', d' - d)"
by simp

lemma match_ex_table_compxEs2_stack_conv:
  "d > 0  match_ex_table P C pc (compxEs2 es 0 d) = (pc', d')  d'  d  match_ex_table P C pc (compxEs2 es 0 0) = (pc', d' - d)"
by(simp add: compxEs2_stack_xlift_convs)

lemma fixes e :: "'addr expr1" and es :: "'addr expr1 list"
  shows match_ex_table_compxE2_not_same: "match_ex_table P C pc (compxE2 e n d) = (pc', d')  pc  pc'"
  and match_ex_table_compxEs2_not_same:"match_ex_table P C pc (compxEs2 es n d) = (pc', d')  pc  pc'"
apply(induct e n d and es n d rule: compxE2_compxEs2_induct)
apply(auto simp add: match_ex_table_append match_ex_entry simp del: compxE2_size_convs compxEs2_size_convs compxE2_stack_xlift_convs compxEs2_stack_xlift_convs split: if_split_asm)
done

end

Theory J1WellType

(*  Title:      JinjaThreads/Compiler/J1WellType.thy
    Author:     Gerwin Klein, Andreas Lochbihler
*)

section ‹Type rules for the intermediate language›

theory J1WellType imports
  J1State
  "../Common/ExternalCallWF"
  "../Common/SemiType"
begin

declare Listn.lesub_list_impl_same_size[simp del] listE_length [simp del]

subsection "Well-Typedness"

type_synonym
  env1  = "ty list"   ― ‹type environment indexed by variable number›

inductive WT1 :: "'addr J1_prog  env1  'addr expr1  ty  bool" ("_,_ ⊢1 _ :: _"   [51,0,0,51] 50)
  and WTs1 :: "'addr J1_prog  env1  'addr expr1 list  ty list  bool" ("_,_ ⊢1 _ [::] _"   [51,0,0,51]50)
  for P :: "'addr J1_prog"
  where

  WT1New:
  "is_class P C  
  P,E ⊢1 new C :: Class C"

| WT1NewArray:
  " P,E ⊢1 e :: Integer; is_type P (T⌊⌉)  
  P,E ⊢1 newA Te :: T⌊⌉"

| WT1Cast:
  " P,E ⊢1 e :: T; P  U  T  P  T  U; is_type P U 
   P,E ⊢1 Cast U e :: U"

| WT1InstanceOf:
  " P,E ⊢1 e :: T; P  U  T  P  T  U; is_type P U; is_refT U 
   P,E ⊢1 e instanceof U :: Boolean"

| WT1Val:
  "typeof v = Some T 
  P,E ⊢1 Val v :: T"

| WT1Var:
  " E!V = T; V < size E  
  P,E ⊢1 Var V :: T"

| WT1BinOp:
  " P,E ⊢1 e1 :: T1; P,E ⊢1 e2 :: T2; P  T1«bop»T2 :: T 
   P,E ⊢1 e1«bop»e2 :: T"

| WT1LAss:
  " E!i = T;  i < size E; P,E ⊢1 e :: T';  P  T'  T 
   P,E ⊢1 i:=e :: Void"

| WT1AAcc:
  " P,E ⊢1 a :: T⌊⌉; P,E ⊢1 i :: Integer 
   P,E ⊢1 ai :: T"

| WT1AAss:
  " P,E ⊢1 a :: T⌊⌉; P,E ⊢1 i :: Integer; P,E ⊢1 e :: T'; P  T'  T 
   P,E ⊢1 ai := e :: Void"

| WT1ALength:
  "P,E ⊢1 a :: T⌊⌉  P,E ⊢1 a∙length :: Integer"

| WTFAcc1:
  " P,E ⊢1 e :: U; class_type_of' U = C; P  C sees F:T (fm) in D 
   P,E ⊢1 eF{D} :: T"

| WTFAss1:
  " P,E ⊢1 e1 :: U; class_type_of' U = C; P  C sees F:T (fm) in D;  P,E ⊢1 e2 :: T';  P  T'  T 
   P,E ⊢1 e1F{D} := e2 :: Void"

| WTCAS1:
  " P,E ⊢1 e1 :: U; class_type_of' U = C; P  C sees F:T (fm) in D; volatile fm; 
     P,E ⊢1 e2 :: T'; P  T'  T; P,E ⊢1 e3 :: T''; P  T''  T 
   P,E ⊢1 e1∙compareAndSwap(DF, e2, e3) :: Boolean"

| WT1Call:
  " P,E ⊢1 e :: U; class_type_of' U = C; P  C sees M:Ts  T = m in D;
     P,E ⊢1 es [::] Ts'; P  Ts' [≤] Ts 
   P,E ⊢1 eM(es) :: T"

| WT1Block:
  " is_type P T;  P,E@[T] ⊢1 e :: T'; case vo of None  True | v  T'. typeof v = T'  P  T'  T 
    P,E ⊢1 {V:T=vo; e} :: T'"

| WT1Synchronized:
  " P,E ⊢1 o' :: T; is_refT T; T  NT; P,E@[Class Object] ⊢1 e :: T' 
   P,E ⊢1 syncV (o') e :: T'"

| WT1Seq:
  " P,E ⊢1 e1::T1;  P,E ⊢1 e2::T2 
    P,E ⊢1 e1;;e2 :: T2"

| WT1Cond:
  " P,E ⊢1 e :: Boolean;  P,E ⊢1 e1::T1;  P,E ⊢1 e2::T2; P  lub(T1,T2) = T 
   P,E ⊢1 if (e) e1 else e2 :: T"

| WT1While:
  " P,E ⊢1 e :: Boolean;  P,E ⊢1 c::T 
   P,E ⊢1 while (e) c :: Void"

| WT1Throw:
  " P,E ⊢1 e :: Class C; P  C * Throwable   
  P,E ⊢1 throw e :: Void"

| WT1Try:
  " P,E ⊢1 e1 :: T;  P,E@[Class C] ⊢1 e2 :: T; is_class P C 
   P,E ⊢1 try e1 catch(C V) e2 :: T"

| WT1Nil: "P,E ⊢1 [] [::] []"

| WT1Cons: " P,E ⊢1 e :: T; P,E ⊢1 es [::] Ts   P,E ⊢1 e#es [::] T#Ts"

declare WT1_WTs1.intros[intro!]
declare WT1Nil[iff]

inductive_cases WT1_WTs1_cases[elim!]:
  "P,E ⊢1 Val v :: T"
  "P,E ⊢1 Var i :: T"
  "P,E ⊢1 Cast D e :: T"
  "P,E ⊢1 e instanceof U :: T"
  "P,E ⊢1 i:=e :: T"
  "P,E ⊢1 {i:U=vo; e} :: T"
  "P,E ⊢1 e1;;e2 :: T"
  "P,E ⊢1 if (e) e1 else e2 :: T"
  "P,E ⊢1 while (e) c :: T"
  "P,E ⊢1 throw e :: T"
  "P,E ⊢1 try e1 catch(C i) e2 :: T"
  "P,E ⊢1 eF{D} :: T"
  "P,E ⊢1 e1F{D}:=e2 :: T"
  "P,E ⊢1 e∙compareAndSwap(DF, e', e'') :: T"
  "P,E ⊢1 e1 «bop» e2 :: T"
  "P,E ⊢1 new C :: T"
  "P,E ⊢1 newA T'e :: T"
  "P,E ⊢1 ai := e :: T"
  "P,E ⊢1 ai :: T"
  "P,E ⊢1 a∙length :: T"
  "P,E ⊢1 eM(es) :: T"
  "P,E ⊢1 syncV (o') e :: T"
  "P,E ⊢1 insyncV (a) e :: T"
  "P,E ⊢1 [] [::] Ts"
  "P,E ⊢1 e#es [::] Ts"

lemma WTs1_same_size: "P,E ⊢1 es [::] Ts  size es = size Ts"
by (induct es arbitrary: Ts) auto

lemma WTs1_snoc_cases:
  assumes wt: "P,E ⊢1 es @ [e] [::] Ts"
  obtains T Ts' where "P,E ⊢1 es [::] Ts'" "P,E ⊢1 e :: T"
proof -
  from wt have "T Ts'. P,E ⊢1 es [::] Ts'  P,E ⊢1 e :: T"
    by(induct es arbitrary: Ts) auto
  thus thesis by(auto intro: that)
qed

lemma WTs1_append:
  assumes wt: "P,Env ⊢1 es @ es' [::] Ts"
  obtains Ts' Ts'' where "P,Env ⊢1 es [::] Ts'" "P,Env ⊢1 es' [::] Ts''"
proof -
  from wt have "Ts' Ts''. P,Env ⊢1 es [::] Ts'  P,Env ⊢1 es' [::] Ts''"
    by(induct es arbitrary: Ts) auto
  thus ?thesis by(auto intro: that)
qed

lemma WT1_not_contains_insync: "P,E ⊢1 e :: T  ¬ contains_insync e"
  and WTs1_not_contains_insyncs: "P,E ⊢1 es [::] Ts  ¬ contains_insyncs es"
by(induct rule: WT1_WTs1.inducts) auto

lemma WT1_expr_locks: "P,E ⊢1 e :: T  expr_locks e = (λa. 0)"
  and WTs1_expr_lockss: "P,E ⊢1 es [::] Ts  expr_lockss es = (λa. 0)"
by(induct rule: WT1_WTs1.inducts)(auto)

lemma assumes wf: "wf_prog wfmd P"
  shows WT1_unique: "P,E ⊢1 e :: T1  P,E ⊢1 e :: T2  T1 = T2" 
  and WTs1_unique: "P,E ⊢1 es [::] Ts1  P,E ⊢1 es [::] Ts2  Ts1 = Ts2"
apply(induct arbitrary: T2 and Ts2 rule:WT1_WTs1.inducts)
apply blast
apply blast
apply blast
apply blast
apply clarsimp
apply blast
apply(blast dest: WT_binop_fun)
apply blast
apply blast
apply blast
apply blast
apply (blast dest:sees_field_idemp sees_field_fun)
apply (blast dest: sees_field_fun)
apply blast

apply(erule WT1_WTs1_cases)
apply(simp)
apply (blast dest:sees_method_idemp sees_method_fun)

apply blast
apply blast
apply blast
apply(blast dest: is_lub_unique[OF wf])
apply blast
apply blast
apply blast
apply blast
apply blast
done

lemma assumes wf: "wf_prog p P"
  shows WT1_is_type: "P,E ⊢1 e :: T  set E  types P  is_type P T"
  and WTs1_is_type: "P,E ⊢1 es [::] Ts  set E  types P  set Ts  types P"
apply(induct rule:WT1_WTs1.inducts)
apply simp
apply simp
apply simp
apply simp
apply (simp add:typeof_lit_is_type)
apply (fastforce intro:nth_mem)
apply(simp add: WT_binop_is_type)
apply(simp)
apply(simp del: is_type_array add: is_type_ArrayD)
apply(simp)
apply(simp)
apply (simp add:sees_field_is_type[OF _ wf])
apply simp
apply simp
apply(fastforce dest!: sees_wf_mdecl[OF wf] simp:wf_mdecl_def)
apply(simp)
apply(simp add: is_class_Object[OF wf])
apply simp
apply(blast dest: is_lub_is_type[OF wf])
apply simp
apply simp
apply simp
apply simp
apply(simp)
done

lemma blocks1_WT:
  " P,Env @ Ts ⊢1 body :: T; set Ts  types P   P,Env ⊢1 blocks1 (length Env) Ts body :: T"
proof(induct n"length Env" Ts body arbitrary: Env rule: blocks1.induct)
  case 1 thus ?case by simp
next
  case (2 T' Ts e)
  note IH = Env'. Suc (length Env) = length Env'; P,Env' @ Ts ⊢1 e :: T; set Ts  types P 
               P,Env' ⊢1 blocks1 (length Env') Ts e :: T
  from ‹set (T' # Ts)  types P have "set Ts  types P" "is_type P T'" by(auto)
  moreover from P,Env @ T' # Ts ⊢1 e :: T have "P,(Env @ [T']) @ Ts ⊢1 e :: T" by simp
  note IH[OF _ this]
  ultimately show ?case by auto
qed

lemma WT1_fv: " P,E ⊢1 e :: T;e (length E); syncvars e   fv e  {0..<length E}"
  and WTs1_fvs: " P,E ⊢1 es [::] Ts; ℬs es (length E); syncvarss es   fvs es  {0..<length E}"
proof(induct rule: WT1_WTs1.inducts)
  case (WT1Synchronized E e1 T e2 T' V)
  note IH1 = e1 (length E); syncvars e1  fv e1  {0..<length E}
  note IH2 = e2 (length (E @ [Class Object])); syncvars e2  fv e2  {0..<length (E @ [Class Object])}
  from ‹ℬ (syncV (e1) e2) (length E) have [simp]: "V = length E"
    and B1: "ℬ e1 (length E)" and B2: "ℬ e2 (Suc (length E))" by auto
  from ‹syncvars (syncV (e1) e2) have sync1: "syncvars e1" and sync2: "syncvars e2" and V: "V  fv e2" by auto
  have "fv e2  {0..<length E}"
  proof
    fix x
    assume x: "x  fv e2"
    with V have "x  length E" by auto
    moreover from IH2 B2 sync2 have "fv e2  {0..<Suc (length E)}" by auto
    with x have "x < Suc (length E)" by auto
    ultimately show "x  {0..<length E}" by auto
  qed
  with IH1[OF B1 sync1] show ?case by(auto)
next
  case (WT1Cond E e e1 T1 e2 T2 T)
  thus ?case by(auto del: subsetI)
qed fastforce+

end

Theory J1WellForm

(*  Title:      JinjaThreads/Compiler/J1WellForm.thy
    Author:     Andreas Lochbihler, Tobias Nipkow
*)

section ‹Well-Formedness of Intermediate Language›

theory J1WellForm imports
  "../J/DefAss"
  J1WellType
begin

subsection‹Well-formedness›

definition wf_J1_mdecl :: "'addr J1_prog  cname  'addr expr1 mdecl  bool"
where
  "wf_J1_mdecl P C    λ(M,Ts,T,body).
    (T'. P,Class C#Ts ⊢1 body :: T'  P  T'  T) 
    𝒟 body {..size Ts} body (size Ts + 1)  syncvars body"

lemma wf_J1_mdecl[simp]:
  "wf_J1_mdecl P C (M,Ts,T,body) 
    ((T'. P,Class C#Ts ⊢1 body :: T'  P  T'  T) 
     𝒟 body {..size Ts} body (size Ts + 1))  syncvars body"
by (simp add:wf_J1_mdecl_def)

abbreviation wf_J1_prog :: "'addr J1_prog  bool"
where "wf_J1_prog == wf_prog wf_J1_mdecl"

end

Theory TypeComp

(*  Title:      JinjaThreads/Compiler/TypeComp.thy
    Author:     Tobias Nipkow, Andreas Lochbihler
*)

section ‹Preservation of Well-Typedness in Stage 2›

theory TypeComp
imports 
  Exception_Tables
  J1WellForm
  "../BV/BVSpec"
  "HOL-Library.Prefix_Order"
  "HOL-Library.Sublist"
begin

(*<*)
declare nth_append[simp]
(*>*)

locale TC0 =
  fixes P :: "'addr J1_prog" and mxl :: nat
begin

definition ty :: "ty list  'addr expr1  ty"
where "ty E e  THE T. P,E ⊢1 e :: T"

definition tyl :: "ty list  nat set  tyl"
where "tyl E A'  map (λi. if i  A'  i < size E then OK(E!i) else Err) [0..<mxl]"

definition tyi' :: "ty list  ty list  nat set option  tyi'"
where "tyi' ST E A  case A of None  None | A'  Some(ST, tyl E A')"

definition after :: "ty list  nat set option  ty list  'addr expr1  tyi'"
  where "after E A ST e  tyi' (ty E e # ST) E (A  𝒜 e)"

end

locale TC1 = TC0 +
  fixes wfmd
  assumes wf_prog: "wf_prog wfmd P"
begin

lemma ty_def2 [simp]: "P,E ⊢1 e :: T  ty E e = T"
apply(unfold ty_def ty_def)
apply(blast intro: the_equality WT1_unique[OF wf_prog])
done

end

context TC0 begin

lemma tyi'_None [simp]: "tyi' ST E None = None"
by(simp add:tyi'_def)

lemma tyl_app_diff[simp]:
 "tyl (E@[T]) (A - {size E}) = tyl E A"
by(auto simp add:tyl_def hyperset_defs)

lemma tyi'_app_diff[simp]:
 "tyi' ST (E @ [T]) (A  size E) = tyi' ST E A"
by(auto simp add:tyi'_def hyperset_defs)

lemma tyl_antimono:
 "A  A'  P  tyl E A' [≤] tyl E A"
by(auto simp:tyl_def list_all2_conv_all_nth)


lemma tyi'_antimono:
 "A  A'  P  tyi' ST E A' ≤' tyi' ST E A"
by(auto simp:tyi'_def tyl_def list_all2_conv_all_nth)

lemma tyl_env_antimono:
 "P  tyl (E@[T]) A [≤] tyl E A" 
by(auto simp:tyl_def list_all2_conv_all_nth)


lemma tyi'_env_antimono:
 "P  tyi' ST (E@[T]) A ≤' tyi' ST E A" 
by(auto simp:tyi'_def tyl_def list_all2_conv_all_nth)


lemma tyi'_incr:
 "P  tyi' ST (E @ [T]) insert (size E) A ≤' tyi' ST E A"
by(auto simp:tyi'_def tyl_def list_all2_conv_all_nth)


lemma tyl_incr:
 "P  tyl (E @ [T]) (insert (size E) A) [≤] tyl E A"
by(auto simp: hyperset_defs tyl_def list_all2_conv_all_nth)


lemma tyl_in_types:
 "set E  types P  tyl E A  list mxl (err (types P))"
by(auto simp add:tyl_def intro!:listI dest!: nth_mem)


function compT :: "ty list  nat hyperset  ty list  'addr expr1  tyi' list"
  and compTs :: "ty list  nat hyperset  ty list  'addr expr1 list  tyi' list"
where
  "compT E A ST (new C) = []"
| "compT E A ST (newA Te) = compT E A ST e @ [after E A ST e]"
| "compT E A ST (Cast C e) = compT E A ST e @ [after E A ST e]"
| "compT E A ST (e instanceof T) = compT E A ST e @ [after E A ST e]"
| "compT E A ST (Val v) = []"
| "compT E A ST (e1 «bop» e2) =
  (let ST1 = ty E e1#ST; A1 = A  𝒜 e1 in
   compT E A ST e1 @ [after E A ST e1] @
   compT E A1 ST1 e2 @ [after E A1 ST1 e2])"
| "compT E A ST (Var i) = []"
| "compT E A ST (i := e) = compT E A ST e @ [after E A ST e, tyi' ST E (A  𝒜 e  {i})]"
| "compT E A ST (ai) =
  (let ST1 = ty E a # ST; A1 = A  𝒜 a
   in  compT E A ST a @ [after E A ST a] @ compT E A1 ST1 i @ [after E A1 ST1 i])"
| "compT E A ST (ai := e) =
  (let ST1 = ty E a # ST; A1 = A  𝒜 a;
       ST2 = ty E i # ST1; A2 = A1  𝒜 i; A3 = A2  𝒜 e
   in compT E A ST a @ [after E A ST a] @ compT E A1 ST1 i @ [after E A1 ST1 i] @ compT E A2 ST2 e @ [after E A2 ST2 e, tyi' ST E A3])"
| "compT E A ST (a∙length) = compT E A ST a @ [after E A ST a]"
| "compT E A ST (eF{D}) = compT E A ST e @ [after E A ST e]"
| "compT E A ST (e1F{D} := e2) =
  (let ST1 = ty E e1#ST; A1 = A  𝒜 e1; A2 = A1  𝒜 e2
   in  compT E A ST e1 @ [after E A ST e1] @ compT E A1 ST1 e2 @ [after E A1 ST1 e2] @ [tyi' ST E A2])"
| "compT E A ST (e1∙compareAndSwap(DF, e2, e3)) =
  (let ST1 = ty E e1 # ST; A1 = A  𝒜 e1; ST2 = ty E e2 # ST1; A2 = A1  𝒜 e2; A3 = A2  𝒜 e3
   in  compT E A ST e1 @ [after E A ST e1] @ compT E A1 ST1 e2 @ [after E A1 ST1 e2] @ compT E A2 ST2 e3 @ [after E A2 ST2 e3])"
| "compT E A ST (eM(es)) =
   compT E A ST e @ [after E A ST e] @
   compTs E (A  𝒜 e) (ty E e # ST) es"
| "compT E A ST {i:T=None; e} = compT (E@[T]) (Ai) ST e"
| "compT E A ST {i:T=v; e} = 
   [after E A ST (Val v), tyi' ST (E@[T]) (A  {i})] @ compT (E@[T]) (A  {i}) ST e"

| "compT E A ST (synci (e1) e2) =
  (let A1 = A  𝒜 e1  {i}; E1 = E @ [Class Object]; ST2 = ty E1 e2 # ST; A2 = A1  𝒜 e2
   in  compT E A ST e1 @
       [after E A ST e1,
        tyi' (Class Object # Class Object # ST) E (A  𝒜 e1),
        tyi' (Class Object # ST) E1 A1,
        tyi' ST E1 A1] @
       compT E1 A1 ST e2 @ 
       [tyi' ST2 E1 A2, tyi' (Class Object # ST2) E1 A2, tyi' ST2 E1 A2, 
        tyi' (Class Throwable # ST) E1 A1,
        tyi' (Class Object # Class Throwable # ST) E1 A1,
        tyi' (Class Throwable # ST) E1 A1])"
| "compT E A ST (insynci (a) e) = []"

| "compT E A ST (e1;;e2) =
  (let A1 = A  𝒜 e1 in
   compT E A ST e1 @ [after E A ST e1, tyi' ST E A1] @
   compT E A1 ST e2)"
| "compT E A ST (if (e) e1 else e2) =
   (let A0 = A  𝒜 e; τ = tyi' ST E A0 in
    compT E A ST e @ [after E A ST e, τ] @
    compT E A0 ST e1 @ [after E A0 ST e1, τ] @
    compT E A0 ST e2)"
| "compT E A ST (while (e) c) =
   (let A0 = A  𝒜 e;  A1 = A0  𝒜 c; τ = tyi' ST E A0 in
    compT E A ST e @ [after E A ST e, τ] @
    compT E A0 ST c @ [after E A0 ST c, tyi' ST E A1, tyi' ST E A0])"
| "compT E A ST (throw e) = compT E A ST e @ [after E A ST e]"
| "compT E A ST (try e1 catch(C i) e2) =
   compT E A ST e1 @ [after E A ST e1] @
   [tyi' (Class C#ST) E A, tyi' ST (E@[Class C]) (A  {i})] @
   compT (E@[Class C]) (A  {i}) ST e2"

| "compTs E A ST [] = []"
| "compTs E A ST (e#es) = compT E A ST e @ [after E A ST e] @
                            compTs E (A  (𝒜 e)) (ty E e # ST) es"
by pat_completeness simp_all
termination
apply(relation "case_sum (λp. size (snd (snd (snd p)))) (λp. size_list size (snd (snd (snd p)))) <*mlex*> {}")
apply(rule wf_mlex[OF wf_empty])
apply(rule mlex_less, simp)+
done

lemmas compT_compTs_induct =
  compT_compTs.induct[
    unfolded meta_all5_eq_conv meta_all4_eq_conv meta_all3_eq_conv meta_all2_eq_conv meta_all_eq_conv,
    case_names
      new NewArray Cast InstanceOf Val BinOp Var LAss AAcc AAss ALen FAcc FAss CompareAndSwap Call BlockNone BlockSome
      Synchronized InSynchronized Seq Cond While throw TryCatch
      Nil Cons]

definition compTa :: "ty list  nat hyperset  ty list  'addr expr1  tyi' list"
where "compTa E A ST e  compT E A ST e @ [after E A ST e]"

lemmas compE2_not_Nil = compE2_neq_Nil
declare compE2_not_Nil[simp]

lemma compT_sizes[simp]:
  shows "size(compT E A ST e) = size(compE2 e) - 1"
  and "size(compTs E A ST es) = size(compEs2 es)"
apply(induct E A ST e and E A ST es rule: compT_compTs_induct)
apply(auto split:nat_diff_split)
done

lemma compT_None_not_Some [simp]: "τ  set (compT E None ST e)"
  and compTs_None_not_Some [simp]: "τ  set (compTs E None ST es)"
by(induct E A"None :: nat hyperset" ST e and E A"None :: nat hyperset" ST es rule: compT_compTs_induct) (simp_all add:after_def)

lemma pair_eq_tyi'_conv:
  "((ST, LT) = tyi' ST0 E A) = (case A of None  False | Some A  (ST = ST0  LT = tyl E A))"
by(simp add:tyi'_def)

lemma pair_conv_tyi': "(ST, tyl E A) = tyi' ST E A"
by(simp add:tyi'_def)

lemma tyi'_antimono2:
 " E  E'; A  A'   P  tyi' ST E' A' ≤' tyi' ST E A"
by(auto simp:tyi'_def tyl_def list_all2_conv_all_nth less_eq_list_def prefix_def)

declare tyi'_antimono [intro!] after_def[simp] pair_conv_tyi'[simp] pair_eq_tyi'_conv[simp]

lemma compT_LT_prefix:
  " (ST,LT)  set(compT E A ST0 e);e (size E)   P  (ST,LT) ≤' tyi' ST E A"
  and compTs_LT_prefix:
  " (ST,LT)  set(compTs E A ST0 es); ℬs es (size E)   P  (ST,LT) ≤' tyi' ST E A"
proof(induct E A ST0 e and E A ST0 es rule: compT_compTs_induct)
  case FAss thus ?case by(fastforce simp:hyperset_defs elim!:sup_state_opt_trans)
next
  case BinOp thus ?case
    by(fastforce simp:hyperset_defs elim!:sup_state_opt_trans split:bop.splits)
next
  case Seq thus ?case by(fastforce simp:hyperset_defs elim!:sup_state_opt_trans)
next
  case While thus ?case by(fastforce simp:hyperset_defs elim!:sup_state_opt_trans)
next
  case Cond thus ?case by(fastforce simp:hyperset_defs elim!:sup_state_opt_trans)
next
  case BlockNone thus ?case by(auto)
next
  case BlockSome thus ?case
    by(clarsimp simp only: tyi'_def)(fastforce intro: tyi'_incr simp add: hyperset_defs elim: sup_state_opt_trans)
next
  case Call thus ?case by(fastforce simp:hyperset_defs elim!:sup_state_opt_trans)
next
  case Cons thus ?case
    by(fastforce simp:hyperset_defs elim!:sup_state_opt_trans)
next
  case TryCatch thus ?case
    by(fastforce simp:hyperset_defs intro!: tyi'_incr elim!:sup_state_opt_trans)
next
  case NewArray thus ?case by(auto simp add: hyperset_defs)
next
  case AAcc thus ?case by(fastforce simp:hyperset_defs elim!:sup_state_opt_trans)
next
  case AAss thus ?case by(auto simp:hyperset_defs Un_ac elim!:sup_state_opt_trans)
next
  case ALen thus ?case by(auto simp add: hyperset_defs)
next
  case CompareAndSwap thus ?case by(auto simp: hyperset_defs Un_ac elim!:sup_state_opt_trans)
next
  case Synchronized thus ?case
    by(fastforce simp add: hyperset_defs elim: sup_state_opt_trans intro: sup_state_opt_trans[OF tyi'_incr] tyi'_antimono2)
qed (auto simp:hyperset_defs)

declare tyi'_antimono [rule del] after_def[simp del] pair_conv_tyi'[simp del] pair_eq_tyi'_conv[simp del]

lemma OK_None_states [iff]: "OK None  states P mxs mxl"
by(simp add: JVM_states_unfold)

end

context TC1 begin

lemma after_in_states:
 " P,E ⊢1 e :: T; set E  types P; set ST  types P; size ST + max_stack e  mxs 
  OK (after E A ST e)  states P mxs mxl"
apply(subgoal_tac "size ST + 1  mxs")
 apply(simp add:after_def tyi'_def JVM_states_unfold tyl_in_types)
 apply(clarify intro!: exI)
 apply(rule conjI)
  apply(rule exI[where x="length ST + 1"], fastforce)
 apply(clarsimp)
 apply(rule conjI[OF WT1_is_type[OF wf_prog]], auto intro: listI)
using max_stack1[of e] by simp

end

context TC0 begin

lemma OK_tyi'_in_statesI [simp]:
  " set E  types P; set ST  types P; size ST  mxs 
   OK (tyi' ST E A)  states P mxs mxl"
apply(simp add:tyi'_def JVM_states_unfold tyl_in_types)
apply(blast intro!:listI)
done

end

lemma is_class_type_aux: "is_class P C  is_type P (Class C)"
by(simp)

context TC1 begin

declare is_type.simps[simp del] subsetI[rule del]

theorem
  shows compT_states:
  " P,E ⊢1 e :: T; set E  types P; set ST  types P;
     size ST + max_stack e  mxs; size E + max_vars e  mxl 
   OK ` set(compT E A ST e)  states P mxs mxl"
  (is "PROP ?P e E T A ST")

  and compTs_states: 
  " P,E ⊢1 es[::]Ts;  set E  types P; set ST  types P;
    size ST + max_stacks es  mxs; size E + max_varss es  mxl 
   OK ` set(compTs E A ST es)  states P mxs mxl"
    (is "PROP ?Ps es E Ts A ST")
proof(induct E A ST e and E A ST es arbitrary: T and Ts rule: compT_compTs_induct)
  case new thus ?case by(simp)
next
  case (Cast C e) thus ?case by (auto simp:after_in_states)
next
  case InstanceOf thus ?case by (auto simp:after_in_states)
next
  case Val thus  ?case by(simp)
next
  case Var thus ?case by(simp)
next
  case LAss thus ?case  by(auto simp:after_in_states)
next
  case FAcc thus ?case by(auto simp:after_in_states)
next
  case FAss thus ?case
    by(auto simp:image_Un WT1_is_type[OF wf_prog] after_in_states)
next
  case CompareAndSwap thus ?case  by(auto simp:image_Un WT1_is_type[OF wf_prog] after_in_states)
next
  case Seq thus ?case
    by(auto simp:image_Un after_in_states)
next
  case BinOp thus ?case
    by(auto simp:image_Un WT1_is_type[OF wf_prog] after_in_states)
next
  case Cond thus ?case
    by(force simp:image_Un WT1_is_type[OF wf_prog] after_in_states)
next
  case While thus ?case
    by(auto simp:image_Un WT1_is_type[OF wf_prog] after_in_states)
next
  case BlockNone thus ?case by auto
next
  case (BlockSome E A ST i ty v exp)
  with max_stack1[of exp] show ?case by(auto intro: after_in_states)
next
  case (TryCatch E A ST e1 C i e2)
  moreover have "size ST + 1  mxs" using TryCatch.prems max_stack1[of e1] by auto
  ultimately show ?case  
    by(auto simp:image_Un WT1_is_type[OF wf_prog] after_in_states
                  is_class_type_aux)
next
  case Nil thus ?case by simp
next
  case Cons thus ?case
    by(auto simp:image_Un  WT1_is_type[OF wf_prog] after_in_states)
next
  case throw thus ?case
    by(auto simp: WT1_is_type[OF wf_prog] after_in_states)
next
  case Call thus ?case
    by(auto simp:image_Un WT1_is_type[OF wf_prog] after_in_states)
next
  case NewArray thus ?case
    by(auto simp:image_Un WT1_is_type[OF wf_prog] after_in_states)
next
  case AAcc thus ?case by(auto simp:image_Un WT1_is_type[OF wf_prog] after_in_states)
next
  case AAss thus ?case by(auto simp:image_Un WT1_is_type[OF wf_prog] after_in_states)
next
  case ALen thus ?case by(auto simp:image_Un WT1_is_type[OF wf_prog] after_in_states)
next
  case InSynchronized thus ?case by auto
next
  case (Synchronized E A ST i exp1 exp2)
  from P,E ⊢1 synci (exp1) exp2 :: T obtain T1
    where wt1: "P,E ⊢1 exp1 :: T1" and T1: "is_refT T1" "T1  NT"
    and wt2: "P,E@[Class Object] ⊢1 exp2 :: T" by auto
  moreover note E = ‹set E  types P with wf_prog
  have E': "set (E@[Class Object])  types P" by(auto simp add: is_type.simps)
  moreover from wf_prog wt2 E' have T: "is_type P T" by(rule WT1_is_type)
  note ST = ‹set ST  types P with wf_prog
  have ST': "set (Class Object # ST)  types P" by(auto simp add: is_type.simps)
  moreover from wf_prog have throwable: "is_type P (Class Throwable)"
    unfolding is_type.simps by(rule is_class_Throwable)
  ultimately show ?case using Synchronized max_stack1[of exp2] T
    by(auto simp add: image_Un after_in_states)
qed

declare is_type.simps[simp] subsetI[intro!]

end


locale TC2 = TC0 +
  fixes Tr :: ty and mxs :: pc
begin
  
definition
  wt_instrs :: "'addr instr list  ex_table  tyi' list  bool" ("( _, _ /[::]/ _)" [0,0,51] 50)
where
  " is,xt [::] τs  size is < size τs  pcs xt  {0..<size is}  (pc< size is. P,Tr,mxs,size τs,xt  is!pc,pc :: τs)"

lemmas wt_defs = wt_instrs_def wt_instr_def app_def eff_def norm_eff_def

lemma wt_instrs_Nil [simp]: "τs  []   [],[] [::] τs"
by(simp add:wt_defs)

end

locale TC3 = TC1 + TC2

lemma eff_None [simp]: "eff i P pc et None = []"
by (simp add: Effect.eff_def)

declare split_comp_eq[simp del]

lemma wt_instr_appR:
 " P,T,m,mpc,xt  is!pc,pc :: τs;
    pc < size is; size is < size τs; mpc  size τs; mpc  mpc' 
   P,T,m,mpc',xt  is!pc,pc :: τs@τs'"
by (fastforce simp:wt_instr_def app_def)


lemma relevant_entries_shift [simp]:
  "relevant_entries P i (pc+n) (shift n xt) = shift n (relevant_entries P i pc xt)"
  apply (induct xt)
  apply (unfold relevant_entries_def shift_def) 
   apply simp
  apply (auto simp add: is_relevant_entry_def)
  done



lemma xcpt_eff_shift [simp]:
  "xcpt_eff i P (pc+n) τ (shift n xt) =
   map (λ(pc,τ). (pc + n, τ)) (xcpt_eff i P pc τ xt)"
apply(simp add: xcpt_eff_def)
apply(cases τ)
apply(auto simp add: shift_def)
done


lemma  eff_shift [simp]:
  "appi (i, P, pc, m, T, τ) 
   eff i P (pc+n) (shift n xt) (Some τ) =
   map (λ(pc,τ). (pc+n,τ)) (eff i P pc xt (Some τ))"
apply(simp add:eff_def norm_eff_def)
apply(cases "i",auto)
done


lemma xcpt_app_shift [simp]:
  "xcpt_app i P (pc+n) m (shift n xt) τ = xcpt_app i P pc m xt τ"
by (simp add: xcpt_app_def) (auto simp add: shift_def)


lemma wt_instr_appL:
  " P,T,m,mpc,xt  i,pc :: τs; pc < size τs; mpc  size τs 
   P,T,m,mpc + size τs',shift (size τs') xt  i,pc+size τs' :: τs'@τs"
apply(clarsimp simp add: wt_instr_def app_def)
apply(auto)
apply(cases "i", auto)
done


lemma wt_instr_Cons:
  " P,T,m,mpc - 1,[]  i,pc - 1 :: τs;
     0 < pc; 0 < mpc; pc < size τs + 1; mpc  size τs + 1 
   P,T,m,mpc,[]  i,pc :: τ#τs"
apply(drule wt_instr_appL[where τs' = "[τ]"])
apply arith
apply arith
apply (simp split:nat_diff_split_asm)
done


lemma wt_instr_append:
  " P,T,m,mpc - size τs',[]  i,pc - size τs' :: τs;
     size τs'  pc; size τs'  mpc; pc < size τs + size τs'; mpc  size τs + size τs' 
   P,T,m,mpc,[]  i,pc :: τs'@τs"
apply(drule wt_instr_appL[where τs' = τs'])
apply arith
apply arith
apply (simp split:nat_diff_split_asm)
done


lemma xcpt_app_pcs:
  "pc  pcs xt  xcpt_app i P pc mxs xt τ"
by (auto simp add: xcpt_app_def relevant_entries_def is_relevant_entry_def pcs_def)


lemma xcpt_eff_pcs:
  "pc  pcs xt  xcpt_eff i P pc τ xt = []"
by (cases τ)
   (auto simp add: is_relevant_entry_def xcpt_eff_def relevant_entries_def pcs_def
           intro!: filter_False)


lemma pcs_shift:
  "pc < n  pc  pcs (shift n xt)" 
by (auto simp add: shift_def pcs_def)

lemma xcpt_eff_shift_pc_ge_n: assumes "x  set (xcpt_eff i P pc τ (shift n xt))"
  shows "n  pc"
proof -
  { assume "pc < n"
    hence "pc  pcs (shift n xt)" by(rule pcs_shift)
    with assms have False
      by(auto simp add: pcs_def xcpt_eff_def is_relevant_entry_def relevant_entries_def split_beta cong: filter_cong) }
  thus ?thesis by(cases "n  pc")(auto)
qed

lemma wt_instr_appRx:
  " P,T,m,mpc,xt  is!pc,pc :: τs; pc < size is; size is < size τs; mpc  size τs 
   P,T,m,mpc,xt @ shift (size is) xt'  is!pc,pc :: τs"
apply(clarsimp simp:wt_instr_def eff_def app_def)
apply(fastforce dest: xcpt_eff_shift_pc_ge_n intro!: xcpt_app_pcs[OF pcs_shift])
done

lemma wt_instr_appLx: 
  " P,T,m,mpc,xt  i,pc :: τs; pc  pcs xt' 
   P,T,m,mpc,xt'@xt  i,pc :: τs"
by (auto simp:wt_instr_def app_def eff_def xcpt_app_pcs xcpt_eff_pcs)


context TC2 begin

lemma wt_instrs_extR:
  " is,xt [::] τs   is,xt [::] τs @ τs'"
by(auto simp add:wt_instrs_def wt_instr_appR)


lemma wt_instrs_ext:
  "  is1,xt1 [::] τs1@τs2;  is2,xt2 [::] τs2; size τs1 = size is1 
    is1@is2, xt1 @ shift (size is1) xt2 [::] τs1@τs2"
apply(clarsimp simp:wt_instrs_def)
apply(rule conjI, fastforce)
apply(rule conjI, fastforce simp add: pcs_shift_conv)
apply clarsimp
apply(rule conjI, fastforce simp:wt_instr_appRx)
apply clarsimp
apply(erule_tac x = "pc - size is1" in allE)+
apply(thin_tac "P  Q" for P Q)
apply(erule impE, arith) 
apply(drule_tac τs' = "τs1" in wt_instr_appL)
  apply arith
 apply simp
apply(fastforce simp add:add.commute intro!: wt_instr_appLx)
done


corollary wt_instrs_ext2:
  "  is2,xt2 [::] τs2;  is1,xt1 [::] τs1@τs2; size τs1 = size is1 
    is1@is2, xt1 @ shift (size is1) xt2 [::] τs1@τs2"
by(rule wt_instrs_ext)


corollary wt_instrs_ext_prefix [trans]:
  "  is1,xt1 [::] τs1@τs2;  is2,xt2 [::] τs3;
     size τs1 = size is1; τs3  τs2 
    is1@is2, xt1 @ shift (size is1) xt2 [::] τs1@τs2"
by(bestsimp simp:less_eq_list_def prefix_def elim: wt_instrs_ext dest:wt_instrs_extR)


corollary wt_instrs_app:
  assumes is1: " is1,xt1 [::] τs1@[τ]"
  assumes is2: " is2,xt2 [::] τ#τs2"
  assumes s: "size τs1 = size is1"
  shows " is1@is2, xt1@shift (size is1) xt2 [::] τs1@τ#τs2"
proof -
  from is1 have " is1,xt1 [::] (τs1@[τ])@τs2"
    by (rule wt_instrs_extR)
  hence " is1,xt1 [::] τs1@τ#τs2" by simp
  from this is2 s show ?thesis by (rule wt_instrs_ext) 
qed


corollary wt_instrs_app_last[trans]:
  "  is2,xt2 [::] τ#τs2;  is1,xt1 [::] τs1;
     last τs1 = τ;  size τs1 = size is1+1 
    is1@is2, xt1@shift (size is1) xt2 [::] τs1@τs2"
apply(cases τs1 rule:rev_cases)
 apply simp
apply(simp add:wt_instrs_app)
done


corollary wt_instrs_append_last[trans]:
  "  is,xt [::] τs; P,Tr,mxs,mpc,[]  i,pc :: τs;
     pc = size is; mpc = size τs; size is + 1 < size τs 
    is@[i],xt [::] τs"
apply(clarsimp simp add:wt_instrs_def)
apply(rule conjI, fastforce)
apply(fastforce intro!:wt_instr_appLx[where xt = "[]",simplified]
               dest!:less_antisym)
done


corollary wt_instrs_app2:
  "  (is2 :: 'b instr list),xt2 [::] τ'#τs2;   is1,xt1 [::] τ#τs1@[τ'];
     xt' = xt1 @ shift (size is1) xt2;  size τs1+1 = size is1 
    is1@is2,xt' [::] τ#τs1@τ'#τs2"
using wt_instrs_app[where ?τs1.0 = "τ # τs1" and ?'b = "'b"] by simp


corollary wt_instrs_app2_simp[trans,simp]:
  "  (is2 :: 'b instr list),xt2 [::] τ'#τs2;   is1,xt1 [::] τ#τs1@[τ']; size τs1+1 = size is1 
    is1@is2, xt1@shift (size is1) xt2 [::] τ#τs1@τ'#τs2"
using wt_instrs_app[where ?τs1.0 = "τ # τs1" and ?'b = "'b"] by simp


corollary wt_instrs_Cons[simp]:
  " τs  [];  [i],[] [::] [τ,τ'];  is,xt [::] τ'#τs 
    i#is,shift 1 xt [::] τ#τ'#τs"
using wt_instrs_app2[where ?is1.0 = "[i]" and ?τs1.0 = "[]" and ?is2.0 = "is"
                      and ?xt1.0 = "[]"]
by simp


corollary wt_instrs_Cons2[trans]:
  assumes τs: " is,xt [::] τs"
  assumes i: "P,Tr,mxs,mpc,[]  i,0 :: τ#τs"
  assumes mpc: "mpc = size τs + 1"
  shows " i#is,shift 1 xt [::] τ#τs"
proof -
  from τs have "τs  []" by (auto simp: wt_instrs_def)
  with mpc i have " [i],[] [::] [τ]@τs" by (simp add: wt_instrs_def)
  with τs show ?thesis by (fastforce dest: wt_instrs_ext)
qed


lemma wt_instrs_last_incr[trans]:
  "  is,xt [::] τs@[τ]; P  τ ≤' τ'    is,xt [::] τs@[τ']"
apply(clarsimp simp add:wt_instrs_def wt_instr_def)
apply(rule conjI)
apply(fastforce)
apply(clarsimp)
apply(rename_tac pc' tau')
apply(erule allE, erule (1) impE)
apply(clarsimp)
apply(drule (1) bspec)
apply(clarsimp)
apply(subgoal_tac "pc' = size τs")
prefer 2
apply(clarsimp simp:app_def)
apply(drule (1) bspec)
apply(clarsimp)
apply(auto elim!:sup_state_opt_trans)
done

end

lemma [iff]: "xcpt_app i P pc mxs [] τ"
by (simp add: xcpt_app_def relevant_entries_def)


lemma [simp]: "xcpt_eff i P pc τ [] = []"
by (simp add: xcpt_eff_def relevant_entries_def)

context TC2 begin

lemma wt_New:
  " is_class P C; size ST < mxs  
    [New C],[] [::] [tyi' ST E A, tyi' (Class C#ST) E A]"
by(simp add:wt_defs tyi'_def)


lemma wt_Cast:
  "is_type P T 
    [Checkcast T],[] [::] [tyi' (U # ST) E A, tyi' (T # ST) E A]"
by(simp add: tyi'_def wt_defs)

lemma wt_Instanceof:
  " is_type P T; is_refT U  
    [Instanceof T],[] [::] [tyi' (U # ST) E A, tyi' (Boolean # ST) E A]"
by(simp add: tyi'_def wt_defs)

lemma wt_Push:
  " size ST < mxs; typeof v = Some T 
    [Push v],[] [::] [tyi' ST E A, tyi' (T#ST) E A]"
by(simp add: tyi'_def wt_defs)


lemma wt_Pop:
 " [Pop],[] [::] (tyi' (T#ST) E A # tyi' ST E A # τs)"
by(simp add: tyi'_def wt_defs)

lemma wt_BinOpInstr:
  "P  T1«bop»T2 :: T   [BinOpInstr bop],[] [::] [tyi' (T2 # T1 # ST) E A, tyi' (T # ST) E A]"
by(auto simp:tyi'_def wt_defs dest: WT_binop_WTrt_binop intro: list_all2_refl)

lemma wt_Load:
  " size ST < mxs; size E  mxl; i ∈∈ A; i < size E 
    [Load i],[] [::] [tyi' ST E A, tyi' (E!i # ST) E A]"
by(auto simp add:tyi'_def wt_defs tyl_def hyperset_defs intro: widens_refl)


lemma wt_Store:
 " P  T  E!i; i < size E; size E  mxl  
   [Store i],[] [::] [tyi' (T#ST) E A, tyi' ST E ({i}  A)]"
by(auto simp:hyperset_defs nth_list_update tyi'_def wt_defs tyl_def
        intro:list_all2_all_nthI)


lemma wt_Get:
 " P  C sees F:T (fm) in D; class_type_of' U = C  
   [Getfield F D],[] [::] [tyi' (U # ST) E A, tyi' (T # ST) E A]"
by(cases U)(auto simp: tyi'_def wt_defs dest: sees_field_idemp sees_field_decl_above intro: widens_refl widen_trans widen_array_object)

lemma wt_Put:
  " P  C sees F:T (fm) in D; class_type_of' U = C; P  T'  T  
   [Putfield F D],[] [::] [tyi' (T' # U # ST) E A, tyi' ST E A]"
by(cases U)(auto 4 3 intro: sees_field_idemp widen_trans widen_array_object dest: sees_field_decl_above simp: tyi'_def wt_defs)

lemma wt_CAS:
  " P  C sees F:T (fm) in D; class_type_of' U' = C; volatile fm; P  T2  T; P  T3  T  
   [CAS F D],[] [::] [tyi' (T3 # T2 # U' # ST) E A, tyi' (Boolean # ST) E A]"
by(cases U')(auto 4 4 simp add: tyi'_def wt_defs intro: sees_field_idemp widen_trans widen_array_object dest: sees_field_decl_above)

lemma wt_Throw:
  "P  C * Throwable   [ThrowExc],[] [::] [tyi' (Class C # ST) E A, τ']"
by(simp add: tyi'_def wt_defs)


lemma wt_IfFalse:
  " 2  i; nat i < size τs + 2; P  tyi' ST E A ≤' τs ! nat(i - 2) 
    [IfFalse i],[] [::] tyi' (Boolean # ST) E A # tyi' ST E A # τs"
by(auto simp add: tyi'_def wt_defs eval_nat_numeral nat_diff_distrib)


lemma wt_Goto:
 " 0  int pc + i; nat (int pc + i) < size τs; size τs  mpc;
    P  τs!pc ≤' τs ! nat (int pc + i) 
  P,T,mxs,mpc,[]  Goto i,pc :: τs"
by(clarsimp simp add: wt_defs)

end

context TC3 begin

lemma wt_Invoke:
  " size es = size Ts'; class_type_of' U = C; P  C sees M: TsT = m in D; P  Ts' [≤] Ts 
    [Invoke M (size es)],[] [::] [tyi' (rev Ts' @ U # ST) E A, tyi' (T#ST) E A]"
apply(clarsimp simp add: tyi'_def wt_defs)
apply safe
apply(simp_all (no_asm_use))
apply(auto simp add: intro: widens_refl)
done

end

declare nth_append[simp del]
declare [[simproc del: list_to_set_comprehension]]

context TC2 begin

corollary wt_instrs_app3[simp]:
  "  (is2 :: 'b instr list),[] [::] (τ' # τs2);   is1,xt1 [::] τ # τs1 @ [τ']; size τs1+1 = size is1
    (is1 @ is2),xt1 [::] τ # τs1 @ τ' # τs2"
using wt_instrs_app2[where ?xt2.0 = "[]" and ?'b = "'b"] by (simp add:shift_def)


corollary wt_instrs_Cons3[simp]:
  " τs  [];  [i],[] [::] [τ,τ'];  is,[] [::] τ'#τs 
    (i # is),[] [::] τ # τ' # τs"
using wt_instrs_Cons[where ?xt = "[]"]
by (simp add:shift_def)

lemma wt_instrs_xapp:
  "  is1 @ is2, xt [::] τs1 @ tyi' (Class D # ST) E A # τs2;
     τ  set τs1. ST' LT'. τ = Some(ST',LT')  
      size ST  size ST'  P  Some (drop (size ST' - size ST) ST',LT') ≤' tyi' ST E A;
     size is1 = size τs1; size ST < mxs; case Co of None  D = Throwable | Some C  D = C  is_class P C   
   is1 @ is2, xt @ [(0,size is1 - Suc n,Co,size is1,size ST)] [::] τs1 @ tyi' (Class D # ST) E A # τs2"
apply(simp add:wt_instrs_def split del: option.split_asm)
apply(rule conjI)
 apply(clarsimp split del: option.split_asm)
 apply arith
apply(clarsimp split del: option.split_asm)
apply(erule allE, erule (1) impE)
apply(clarsimp simp add: wt_instr_def app_def eff_def split del: option.split_asm)
apply(rule conjI)
 apply (thin_tac "x A  B. P x" for A B P)
 apply (thin_tac "x A  B. P x" for A B P)
 apply (clarsimp simp add: xcpt_app_def relevant_entries_def split del: option.split_asm)
 apply (simp add: nth_append is_relevant_entry_def split: if_split_asm split del: option.split_asm)
  apply (drule_tac x="τs1!pc" in bspec)
   apply (blast intro: nth_mem) 
  apply fastforce
 apply fastforce
apply (rule conjI)
 apply(clarsimp split del: option.split_asm)
 apply (erule disjE, blast)
 apply (erule disjE, blast)
 apply (clarsimp simp add: xcpt_eff_def relevant_entries_def split: if_split_asm)
apply(clarsimp split del: option.split_asm)
apply (erule disjE, blast)
apply (erule disjE, blast)
apply (clarsimp simp add: xcpt_eff_def relevant_entries_def split: if_split_asm split del: option.split_asm)
apply (simp add: nth_append is_relevant_entry_def split: if_split_asm split del: option.split_asm)
 apply (drule_tac x = "τs1!pc" in bspec)
  apply (blast intro: nth_mem)
 apply (fastforce simp add: tyi'_def)
done

lemma wt_instrs_xapp_Some[trans]:
  "  is1 @ is2, xt [::] τs1 @ tyi' (Class C # ST) E A # τs2;
     τ  set τs1. ST' LT'. τ = Some(ST',LT')  
      size ST  size ST'  P  Some (drop (size ST' - size ST) ST',LT') ≤' tyi' ST E A;
     size is1 = size τs1; is_class P C; size ST < mxs   
   is1 @ is2, xt @ [(0,size is1 - Suc n,Some C,size is1,size ST)] [::] τs1 @ tyi' (Class C # ST) E A # τs2"
by(erule (3) wt_instrs_xapp) simp

lemma wt_instrs_xapp_Any:
  "  is1 @ is2, xt [::] τs1 @ tyi' (Class Throwable # ST) E A # τs2;
     τ  set τs1. ST' LT'. τ = Some(ST',LT')  
      size ST  size ST'  P  Some (drop (size ST' - size ST) ST',LT') ≤' tyi' ST E A;
     size is1 = size τs1; size ST < mxs  
   is1 @ is2, xt @ [(0,size is1 - Suc n,None,size is1,size ST)] [::] τs1 @ tyi' (Class Throwable # ST) E A # τs2"
by(erule (3) wt_instrs_xapp) simp

end

declare [[simproc add: list_to_set_comprehension]]
declare nth_append[simp]

lemma drop_Cons_Suc:
  "xs. drop n xs = y#ys  drop (Suc n) xs = ys"
  apply (induct n)
   apply simp
  apply (simp add: drop_Suc)
  done

lemma drop_mess:
  "Suc (length xs0)  length xs; drop (length xs - Suc (length xs0)) xs = x # xs0 
   drop (length xs - length xs0) xs = xs0"
apply (cases xs)
 apply simp
apply (simp add: Suc_diff_le)
apply (case_tac "length list - length xs0")
 apply simp
apply (simp add: drop_Cons_Suc)
done

lemma drop_mess2:
  assumes len: "Suc (Suc (length xs0))  length xs" 
  and drop: "drop (length xs - Suc (Suc (length xs0))) xs = x1 # x2 # xs0"
  shows "drop (length xs - length xs0) xs = xs0"
proof(cases xs)
  case Nil with assms show ?thesis by simp
next
  case (Cons x xs')
  note Cons[simp]
  show ?thesis
  proof(cases xs')
    case Nil with assms show ?thesis by(simp)
  next
    case (Cons x' xs'')
    note Cons[simp]
    show ?thesis 
    proof(rule drop_mess)
      from len show "Suc (length xs0)  length xs" by simp
    next
      have "drop (length xs - length (x2 # xs0)) xs = x2 # xs0"
      proof(rule drop_mess)
        from len show "Suc (length (x2 # xs0))  length xs" by(simp)
      next
        from drop show "drop (length xs - Suc (length (x2 # xs0))) xs = x1 # x2 # xs0" by simp
      qed
      thus "drop (length xs - Suc (length xs0)) xs = x2 # xs0" by(simp)
    qed
  qed
qed

abbreviation postfix :: "'a list  'a list  bool"  ("(_/  _)" [51, 50] 50) where
  "postfix xs ys  suffix ys xs"

lemma postfix_conv_eq_length_drop: 
  "ST'  ST  length ST  length ST'  drop (length ST' - length ST) ST' = ST"
apply(auto)
apply (metis append_eq_conv_conj append_take_drop_id diff_is_0_eq drop_0 linorder_not_less nat_le_linear suffix_take)
apply (metis append_take_drop_id length_drop suffix_take same_append_eq size_list_def)
by (metis suffix_drop)

declare suffix_ConsI[simp]

context TC0 begin

declare after_def[simp] pair_eq_tyi'_conv[simp] 

lemma
  assumes "ST0  ST'"
  shows compT_ST_prefix: 
  "(ST,LT)  set(compT E A ST0 e)  ST  ST'"

  and compTs_ST_prefix:
  "(ST,LT)  set(compTs E A ST0 es)  ST  ST'"
using assms
by(induct E A ST0 e and E A ST0 es rule: compT_compTs_induct) auto

declare after_def[simp del] pair_eq_tyi'_conv[simp del]

end
declare suffix_ConsI[simp del]

(* FIXME *)
lemma fun_of_simp [simp]: "fun_of S x y = ((x,y)  S)" 
by (simp add: fun_of_def)

declare widens_refl [iff]

context TC3 begin

theorem compT_wt_instrs:
  " P,E ⊢1 e :: T; 𝒟 e A;e (size E); size ST + max_stack e  mxs; size E + max_vars e  mxl; set E  types P 
    compE2 e, compxE2 e 0 (size ST) [::] tyi' ST E A # compT E A ST e @ [after E A ST e]"
  (is "PROP ?P e E T A ST")

  and compTs_wt_instrs:
  " P,E ⊢1 es[::]Ts;  𝒟s es A; ℬs es (size E); size ST + max_stacks es  mxs; size E + max_varss es  mxl; set E  types P 
   let τs = tyi' ST E A # compTs E A ST es
      in  compEs2 es,compxEs2 es 0 (size ST) [::] τs  last τs = tyi' (rev Ts @ ST) E (A  𝒜s es)"
  (is "PROP ?Ps es E Ts A ST")
proof(induct E A ST e and E A ST es arbitrary: T and Ts rule: compT_compTs_induct)
  case (TryCatch E A ST e1 C i e2)
  hence [simp]: "i = size E" by simp
  have wt1: "P,E ⊢1 e1 :: T" and wt2: "P,E@[Class C] ⊢1 e2 :: T"
    and "class": "is_class P C" using TryCatch by auto
  let ?A1 = "A  𝒜 e1" let ?Ai = "A  {i}" let ?Ei = "E @ [Class C]"
  let  = "tyi' ST E A" let ?τs1 = "compT E A ST e1"
  let 1 = "tyi' (T#ST) E ?A1" let 2 = "tyi' (Class C#ST) E A"
  let 3 = "tyi' ST ?Ei ?Ai" let ?τs2 = "compT ?Ei ?Ai ST e2"
  let 2' = "tyi' (T#ST) ?Ei (?Ai  𝒜 e2)"
  let ?τ' = "tyi' (T#ST) E (A  𝒜 e1  (𝒜 e2  i))"
  let ?go = "Goto (int(size(compE2 e2)) + 2)"
  have "PROP ?P e2 ?Ei T ?Ai ST" by fact
  hence " compE2 e2,compxE2 e2 0 (size ST) [::] (3 # ?τs2) @ [2']"
    using TryCatch.prems "class" by(auto simp:after_def)
  also have "?Ai  𝒜 e2 = (A  𝒜 e2)  {size E}"
    by(fastforce simp:hyperset_defs)
  also have "P  tyi' (T#ST) ?Ei  ≤' tyi' (T#ST) E (A  𝒜 e2)"
    by(simp add:hyperset_defs tyl_incr tyi'_def)
  also have "P   ≤' tyi' (T#ST) E (A  𝒜 e1  (𝒜 e2  i))"
    by(auto intro!: tyl_antimono simp:hyperset_defs tyi'_def)
  also have "(3 # ?τs2) @ [?τ'] = 3 # ?τs2 @ [?τ']" by simp
  also have " [Store i],[] [::] 2 # [] @ [3]"
    using TryCatch.prems
    by(auto simp:nth_list_update wt_defs tyi'_def tyl_def
      list_all2_conv_all_nth hyperset_defs)
  also have "[] @ (3 # ?τs2 @ [?τ']) = (3 # ?τs2 @ [?τ'])" by simp
  also have "P,Tr,mxs,size(compE2 e2)+3,[]  ?go,0 :: 1#2#3#?τs2 @ [?τ']"
    by(auto simp: hyperset_defs tyi'_def wt_defs nth_Cons nat_add_distrib
      fun_of_def intro: tyl_antimono list_all2_refl split:nat.split)
  also have " compE2 e1,compxE2 e1 0 (size ST) [::]  # ?τs1 @ [1]"
    using TryCatch by(auto simp:after_def)
  also have " # ?τs1 @ 1 # 2 # 3 # ?τs2 @ [?τ'] =
             ( # ?τs1 @ [1]) @ 2 # 3 # ?τs2 @ [?τ']" by simp
  also have "compE2 e1 @ ?go  # [Store i] @ compE2 e2 =
             (compE2 e1 @ [?go]) @ (Store i # compE2 e2)" by simp
  also 
  let "?Q τ" = "ST' LT'. τ = (ST', LT')  
    size ST  size ST'  P  Some (drop (size ST' - size ST) ST',LT') ≤' tyi' ST E A"
  {
    have "?Q (tyi' ST E A)" by(clarsimp simp add: tyi'_def)
    moreover have "?Q (tyi' (T # ST) E ?A1)" 
      by (fastforce simp add: tyi'_def hyperset_defs intro!: tyl_antimono)
    moreover { fix τ
      assume τ: "τ  set (compT E A ST e1)"
      hence "ST' LT'. τ = (ST', LT')  ST'  ST" by(auto intro: compT_ST_prefix[OF suffix_order.order_refl])
      with τ have "?Q τ" unfolding postfix_conv_eq_length_drop using ‹ℬ (try e1 catch(C i) e2) (length E)
        by(fastforce dest!: compT_LT_prefix simp add: tyi'_def) }
    ultimately
    have "τset (tyi' ST E A # compT E A ST e1 @ [tyi' (T # ST) E ?A1]). ?Q τ" by auto
  }
  also from TryCatch.prems max_stack1[of e1] have "size ST + 1  mxs" by auto
  ultimately show ?case using wt1 wt2 TryCatch.prems "class"
    by (simp add:after_def)(erule_tac x=0 in meta_allE, simp)
next
  case (Synchronized E A ST i e1 e2)
  note wt = P,E ⊢1 synci (e1) e2 :: T
  then obtain U where wt1: "P,E ⊢1 e1 :: U"
    and U: "is_refT U" "U  NT"
    and wt2: "P,E@[Class Object] ⊢1 e2 :: T" by auto
  from ‹ℬ (synci (e1) e2) (length E) have [simp]: "i = length E"
    and B1: "ℬ e1 (length E)" and B2: "ℬ e2 (length (E@[Class Object]))" by auto
  
  note lenST = ‹length ST + max_stack (synci (e1) e2)  mxs 
  note lenE = ‹length E + max_vars (synci (e1) e2)  mxl

  let ?A1 = "A  𝒜 e1" let ?A2 = "?A1  {i}"
  let ?A3 = "?A2  𝒜 e2" let ?A4 = "?A1  𝒜 e2"
  let ?E1 = "E @ [Class Object]"
  let  = "tyi' ST E A" let ?τs1 = "compT E A ST e1"
  let ?τ1 = "tyi' (U#ST) E ?A1"
  let ?τ1' = "tyi' (Class Object # Class Object # ST) E ?A1"
  let ?τ1'' = "tyi' (Class Object#ST) ?E1 ?A2"
  let ?τ1''' = "tyi' ST ?E1 ?A2"
  let ?τs2 = "compT ?E1 ?A2 ST e2"
  let ?τ2 = "tyi' (T#ST) ?E1 ?A3" let ?τ2' = "tyi' (Class Object#T#ST) ?E1 ?A3"
  let ?τ2'' = ?τ2
  let ?τ3 = "tyi' (Class Throwable#ST) ?E1 ?A2"
  let ?τ3' = "tyi' (Class Object#Class Throwable#ST) ?E1 ?A2"
  let ?τ3'' = ?τ3
  let ?τ' = "tyi' (T#ST) E ?A4"

  from lenE lenST max_stack1[of e2] U 
  have " [Load i, MExit, ThrowExc], [] [::] [?τ3, ?τ3', ?τ3'', ?τ']"
    by(auto simp add: tyi'_def tyl_def wt_defs hyperset_defs nth_Cons split: nat.split)
  also have "P,Tr,mxs,5,[]  Goto 4,0 :: [?τ2'', ?τ3, ?τ3', ?τ3'', ?τ']"
    by(auto simp: hyperset_defs tyi'_def wt_defs intro: tyl_antimono tyl_incr)
  also have "P,Tr,mxs,6,[]  MExit,0 :: [?τ2', ?τ2'', ?τ3, ?τ3', ?τ3'', ?τ']"
    by(auto simp: hyperset_defs tyi'_def wt_defs intro: tyl_antimono tyl_incr)
  also from lenE lenST max_stack1[of e2]
  have "P,Tr,mxs,7,[]  Load i,0 :: [?τ2, ?τ2', ?τ2'', ?τ3, ?τ3', ?τ3'', ?τ']"
    by(auto simp: hyperset_defs tyi'_def wt_defs tyl_def intro: tyl_antimono)
  also from ‹𝒟 (synci (e1) e2) A have "𝒟 e2 (A  𝒜 e1  {length E})"
    by(auto elim!: D_mono' simp add: hyperset_defs)
  with PROP ?P e2 ?E1 T ?A2 ST Synchronized wt2 is_class_Object[OF wf_prog]
  have " compE2 e2, compxE2 e2 0 (size ST) [::] ?τ1'''#?τs2@[?τ2]"
    by(auto simp add: after_def)
  finally have " (compE2 e2 @ [Load i, MExit, Goto 4]) @ [Load i, MExit, ThrowExc], compxE2 e2 0 (size ST) [::]
             (?τ1''' # ?τs2 @ [?τ2, ?τ2', ?τ2'']) @ [?τ3, ?τ3', ?τ3'', ?τ']"
    by(simp)
  hence " (compE2 e2 @ [Load i, MExit, Goto 4]) @ [Load i, MExit, ThrowExc],
           compxE2 e2 0 (size ST) @ [(0, size (compE2 e2 @ [Load i, MExit, Goto 4]) - Suc 2, None, size (compE2 e2 @ [Load i, MExit, Goto 4]), size ST)] [::]
           (?τ1''' # ?τs2 @ [?τ2, ?τ2', ?τ2'']) @ [?τ3, ?τ3', ?τ3'', ?τ']"
  proof(rule wt_instrs_xapp_Any)
    from lenST show "length ST < mxs" by simp
  next
    show "τset (?τ1''' # ?τs2 @ [?τ2, ?τ2', ?τ2'']). ST' LT'.
          τ = (ST', LT')  length ST  length ST' 
          P  (drop (length ST' - length ST) ST',  LT') ≤' tyi' ST (E @ [Class Object]) ?A2"
    proof(intro strip)
      fix τ ST' LT'
      assume "τset (?τ1''' # ?τs2 @ [?τ2, ?τ2', ?τ2''])" "τ = (ST', LT')"
      hence τ: "(ST', LT')  set (?τ1''' # ?τs2 @ [?τ2, ?τ2', ?τ2''])" by simp
      show "length ST  length ST'  P  (drop (length ST' - length ST) ST',  LT') ≤' tyi' ST (E @ [Class Object]) ?A2"
      proof(cases "(ST', LT')  set ?τs2")
        case True
        from compT_ST_prefix[OF suffix_order.order_refl this] compT_LT_prefix[OF this B2]
        show ?thesis unfolding postfix_conv_eq_length_drop by(simp add: tyi'_def)
      next
        case False
        with τ show ?thesis
          by(auto simp add: tyi'_def hyperset_defs intro: tyl_antimono)
      qed
    qed
  qed simp
  hence " compE2 e2 @ [Load i, MExit, Goto 4, Load i, MExit, ThrowExc],
           compxE2 e2 0 (size ST) @ [(0, size (compE2 e2), None, Suc (Suc (Suc (size (compE2 e2)))), size ST)] [::]
           ?τ1''' # ?τs2 @ [?τ2, ?τ2', ?τ2'', ?τ3, ?τ3', ?τ3'', ?τ']" by simp
  also from wt1 ‹set E  types P have "is_type P U" by(rule WT1_is_type[OF wf_prog])
  with U have "P  U  Class Object" by(auto elim!: is_refT.cases intro: subcls_C_Object[OF _ wf_prog] widen_array_object)
  with lenE lenST max_stack1[of e2]
  have " [Dup, Store i, MEnter], [] [::] [?τ1, ?τ1', ?τ1''] @ [?τ1''']"
    by(auto simp add: tyi'_def tyl_def wt_defs hyperset_defs nth_Cons nth_list_update list_all2_conv_all_nth split: nat.split)
  finally have " Dup # Store i # MEnter # compE2 e2 @ [Load i, MExit, Goto 4, Load i, MExit, ThrowExc],
               compxE2 e2 3 (size ST) @ [(3, 3 + size (compE2 e2), None, 6 + size (compE2 e2), size ST)]
            [::] ?τ1 # ?τ1' # ?τ1'' # ?τ1''' # ?τs2 @ [?τ2, ?τ2', ?τ2'', ?τ3, ?τ3', ?τ3'', ?τ']"
    by(simp add: eval_nat_numeral shift_def)
  also from PROP ?P e1 E U A ST wt1 B1 ‹𝒟 (synci (e1) e2) A lenE lenST ‹set E  types P
  have " compE2 e1, compxE2 e1 0 (size ST) [::] #?τs1@[?τ1]"
    by(auto simp add: after_def)
  finally show ?case using wt1 wt2 wt by(simp add: after_def ac_simps shift_Cons_tuple hyperUn_assoc)
next
  case new thus ?case by(auto simp add:after_def wt_New)
next
  case (BinOp E A ST e1 bop e2) 
  have T: "P,E ⊢1 e1 «bop» e2 :: T" by fact
  then obtain T1 T2 where T1: "P,E ⊢1 e1 :: T1" and T2: "P,E ⊢1 e2 :: T2" and 
    bopT: "P  T1«bop»T2 :: T" by auto
  let ?A1 = "A  𝒜 e1" let ?A2 = "?A1  𝒜 e2"
  let  = "tyi' ST E A" let ?τs1 = "compT E A ST e1"
  let 1 = "tyi' (T1#ST) E ?A1" let ?τs2 = "compT E ?A1 (T1#ST) e2"
  let 2 = "tyi' (T2#T1#ST) E ?A2" let ?τ' = "tyi' (T#ST) E ?A2"
  from bopT have " [BinOpInstr bop],[] [::] [2,?τ']" by(rule wt_BinOpInstr)
  also from BinOp.hyps(2)[of T2] BinOp.prems T2 T1
  have " compE2 e2, compxE2 e2 0 (size (ty E e1#ST)) [::] 1#?τs2@[2]" by (auto simp: after_def)
  also from BinOp T1 have " compE2 e1, compxE2 e1 0 (size ST) [::] #?τs1@[1]" 
    by (auto simp: after_def)
  finally show ?case using T T1 T2 by (simp add: after_def hyperUn_assoc)
next
  case (Cons E A ST e es)
  have "P,E ⊢1 e # es [::] Ts" by fact
  then obtain Te Ts' where 
    Te: "P,E ⊢1 e :: Te" and Ts': "P,E ⊢1 es [::] Ts'" and
    Ts: "Ts = Te#Ts'" by auto
  let ?Ae = "A  𝒜 e"  
  let  = "tyi' ST E A" let ?τse = "compT E A ST e"  
  let e = "tyi' (Te#ST) E ?Ae" let ?τs' = "compTs E ?Ae (Te#ST) es"
  let ?τs = " # ?τse @ (e # ?τs')"
  from Cons.hyps(2) Cons.prems Te Ts'
  have " compEs2 es, compxEs2 es 0 (size (Te#ST)) [::] e#?τs'" by (simp add: after_def)
  also from Cons Te have " compE2 e, compxE2 e 0 (size ST) [::] #?τse@[e]" by (auto simp: after_def)
  moreover
  from Cons.hyps(2)[OF Ts'] Cons.prems Te Ts' Ts
  have "last ?τs = tyi' (rev Ts@ST) E (?Ae  𝒜s es)" by simp
  ultimately show ?case using Te
    by(auto simp add: after_def hyperUn_assoc shift_compxEs2 stack_xlift_compxEs2 simp del: compxE2_size_convs compxEs2_size_convs compxEs2_stack_xlift_convs compxE2_stack_xlift_convs intro: wt_instrs_app2)
next
  case (FAss E A ST e1 F D e2)
  hence Void: "P,E ⊢1 e1F{D} := e2 :: Void" by auto
  then obtain U C T T' fm where    
    C: "P,E ⊢1 e1 :: U" and U: "class_type_of' U = C" and sees: "P  C sees F:T (fm) in D" and
    T': "P,E ⊢1 e2 :: T'" and T'_T: "P  T'  T" by auto
  let ?A1 = "A  𝒜 e1" let ?A2 = "?A1  𝒜 e2"  
  let  = "tyi' ST E A" let ?τs1 = "compT E A ST e1"
  let 1 = "tyi' (U#ST) E ?A1" let ?τs2 = "compT E ?A1 (U#ST) e2"
  let 2 = "tyi' (T'#U#ST) E ?A2" let 3 = "tyi' ST E ?A2"
  let ?τ' = "tyi' (Void#ST) E ?A2"
  from FAss.prems sees T'_T U
  have " [Putfield F D,Push Unit],[] [::] [2,3,?τ']"
    by (fastforce simp add: wt_Push wt_Put)
  also from FAss.hyps(2)[of T'] FAss.prems T' C
  have " compE2 e2, compxE2 e2 0 (size ST+1) [::] 1#?τs2@[2]"
    by (auto simp add: after_def hyperUn_assoc) 
  also from FAss C have " compE2 e1, compxE2 e1 0 (size ST) [::] #?τs1@[1]" 
    by (auto simp add: after_def)
  finally show ?case using Void C T' by (simp add: after_def hyperUn_assoc) 
next
  case Val thus ?case by(auto simp:after_def wt_Push)
next
  case (Cast T exp) thus ?case by (auto simp:after_def wt_Cast)
next
  case (InstanceOf E A ST e) thus ?case
    by(auto simp:after_def intro!: wt_Instanceof wt_instrs_app3 intro: widen_refT refT_widen)
next
  case (BlockNone E A ST i Ti e)
  from P,E ⊢1 {i:Ti=None; e} :: T have wte: "P,E@[Ti] ⊢1 e :: T"
    and Ti: "is_type P Ti" by auto
  let ?τs = "tyi' ST E A # compT (E @ [Ti]) (Ai) ST e"
  from BlockNone wte Ti
  have " compE2 e, compxE2 e 0 (size ST) [::] ?τs @ [tyi' (T#ST) (E@[Ti]) (A(size E)  𝒜 e)]"
    by(auto simp add: after_def)
  also have "P  tyi' (T # ST) (E@[Ti]) (A  size E  𝒜 e) ≤' tyi' (T # ST) (E@[Ti]) ((A  𝒜 e)  size E)"
    by(auto simp add:hyperset_defs intro: tyi'_antimono)
  also have " = tyi' (T # ST) E (A  𝒜 e)" by simp
  also have "P   ≤' tyi' (T # ST) E (A  (𝒜 e  i))"
    by(auto simp add:hyperset_defs intro: tyi'_antimono)
  finally show ?case using BlockNone.prems by(simp add: after_def)
next
  case (BlockSome E A ST i Ti v e)
  from P,E ⊢1 {i:Ti=v; e} :: T obtain Tv
    where Tv: "P,E ⊢1 Val v :: Tv" "P  Tv  Ti"
    and wte: "P,E@[Ti] ⊢1 e :: T"
    and Ti: "is_type P Ti" by auto
  from ‹length ST + max_stack {i:Ti=v; e}  mxs
  have lenST: "length ST + max_stack e  mxs" by simp
  from ‹length E + max_vars {i:Ti=v; e}  mxl
  have lenE: "length (E@[Ti]) + max_vars e  mxl" by simp
  from ‹ℬ {i:Ti=v; e} (length E) have [simp]: "i = length E"
    and B: "ℬ e (length (E@[Ti]))" by auto


  from BlockSome wte
  have " compE2 e, compxE2 e 0 (size ST) [::] (tyi' ST (E @ [Ti]) (A  {length E}) # compT (E @ [Ti]) (A  {i}) ST e) @ [tyi' (T#ST) (E@[Ti]) (A  {size E}  𝒜 e)]"
    by(auto simp add: after_def)
  also have "P  tyi' (T # ST) (E @ [Ti]) (A  {length E}  𝒜 e) ≤' tyi' (T # ST) (E @ [Ti]) ((A  𝒜 e)  length E)"
    by(auto simp add: hyperset_defs intro: tyi'_antimono)
  also have " = tyi' (T # ST) E (A  𝒜 e)" by simp
  also have "P   ≤' tyi' (T # ST) E (A  (𝒜 e  i))"
    by(auto simp add:hyperset_defs intro: tyi'_antimono)
  also note append_Cons
  also {
    from lenST max_stack1[of e] Tv
    have " [Push v], [] [::] [tyi' ST E A, tyi' (ty E (Val v) # ST) E A]"
      by(auto intro: wt_Push)
    moreover from Tv lenE
    have " [Store (length E)], [] [::] [tyi' (Tv # ST) (E @ [Ti]) (A  length E), tyi' ST (E @ [Ti]) ({length E}  (A  length E))]"
      by -(rule wt_Store, auto)
    moreover have "tyi' (Tv # ST) (E @ [Ti]) (A  length E) = tyi' (Tv # ST) E A" by(simp add: tyi'_def)
    moreover have "{length E}  (A  length E) = A  {length E}" by(simp add: hyperset_defs)
    ultimately have " [Push v, Store (length E)], [] [::] [tyi' ST E A, tyi' (Tv # ST) E A, tyi' ST (E @ [Ti]) (A  {length E})]"
      using Tv by(auto intro: wt_instrs_Cons3)
  }
  finally show ?case using Tv P,E ⊢1 {i:Ti=v; e} :: T wte by(simp add: after_def)
next
  case Var thus ?case by(auto simp:after_def wt_Load)
next
  case FAcc thus ?case by(auto simp:after_def wt_Get)
next
  case (LAss E A ST i e) thus ?case using max_stack1[of e]
    by(auto simp: hyper_insert_comm after_def wt_Store wt_Push simp del: hyperUn_comm hyperUn_leftComm)
next
  case Nil thus ?case by auto
next
  case throw thus ?case by(auto simp add: after_def wt_Throw)
next
  case (While E A ST e c)
  obtain Tc where wte: "P,E ⊢1 e :: Boolean" and wtc: "P,E ⊢1 c :: Tc"
    and [simp]: "T = Void" using While by auto
  have [simp]: "ty E (while (e) c) = Void" using While by simp
  let ?A0 = "A  𝒜 e" let ?A1 = "?A0  𝒜 c"
  let  = "tyi' ST E A" let ?τse = "compT E A ST e"
  let e = "tyi' (Boolean#ST) E ?A0" let 1 = "tyi' ST E ?A0"
  let ?τsc = "compT E ?A0 ST c" let c = "tyi' (Tc#ST) E ?A1"
  let 2 = "tyi' ST E ?A1" let ?τ' = "tyi' (Void#ST) E ?A0"
  let ?τs = "( # ?τse @ [e]) @ 1 # ?τsc @ [c, 2, 1, ?τ']"
  have " [],[] [::] [] @ ?τs" by(simp add:wt_instrs_def)
  also
  from While.hyps(1)[of Boolean] While.prems
  have " compE2 e,compxE2 e 0 (size ST) [::]  # ?τse @ [e]"
    by (auto simp:after_def)
  also
  have "[] @ ?τs = ( # ?τse) @ e # 1 # ?τsc @ [c,2,1,?τ']" by simp
  also
  let ?ne = "size(compE2 e)"  let ?nc = "size(compE2 c)"
  let ?if = "IfFalse (int ?nc + 3)"
  have " [?if],[] [::] e # 1 # ?τsc @ [c, 2, 1, ?τ']"
    by(simp add: wt_instr_Cons wt_instr_append wt_IfFalse
                 nat_add_distrib split: nat_diff_split)
  also
  have "( # ?τse) @ (e # 1 # ?τsc @ [c, 2, 1, ?τ']) = ?τs" by simp
  also from While.hyps(2)[of Tc] While.prems wtc
  have " compE2 c,compxE2 c 0 (size ST) [::] 1 # ?τsc @ [c]"
    by (auto simp:after_def)
  also have "?τs = ( # ?τse @ [e,1] @ ?τsc) @ [c,2,1,?τ']" by simp
  also have " [Pop],[] [::] [c, 2]"  by(simp add:wt_Pop)
  also have "( # ?τse @ [e,1] @ ?τsc) @ [c,2,1,?τ'] = ?τs" by simp
  also let ?go = "Goto (-int(?nc+?ne+2))"
  have "P  2 ≤' " by(fastforce intro: tyi'_antimono simp: hyperset_defs)
  hence "P,Tr,mxs,size ?τs,[]  ?go,?ne+?nc+2 :: ?τs"
    by(simp add: wt_Goto split: nat_diff_split)
  also have "?τs = ( # ?τse @ [e,1] @ ?τsc @ [c, 2]) @ [1, ?τ']"
    by simp
  also have " [Push Unit],[] [::] [1,?τ']"
    using While.prems max_stack1[of c] by(auto simp add:wt_Push)
  finally show ?case using wtc wte
    by (simp add:after_def)
next
  case (Cond E A ST e e1 e2)
  obtain T1 T2 where wte: "P,E ⊢1 e :: Boolean"
    and wt1: "P,E ⊢1 e1 :: T1" and wt2: "P,E ⊢1 e2 :: T2"
    and sub1: "P  T1  T" and sub2: "P  T2  T"
    using Cond by(auto dest: is_lub_upper)
  have [simp]: "ty E (if (e) e1 else e2) = T" using Cond by simp
  let ?A0 = "A  𝒜 e" let ?A2 = "?A0  𝒜 e2" let ?A1 = "?A0  𝒜 e1"
  let ?A' = "?A0  𝒜 e1  𝒜 e2"
  let 2 = "tyi' ST E ?A0" let ?τ' = "tyi' (T#ST) E ?A'"
  let ?τs2 = "compT E ?A0 ST e2"
  have "PROP ?P e2 E T2 ?A0 ST" by fact
  hence " compE2 e2, compxE2 e2 0 (size ST) [::] (2#?τs2) @ [tyi' (T2#ST) E ?A2]"
    using Cond.prems wt2 by(auto simp add:after_def)
  also have "P  tyi' (T2#ST) E ?A2 ≤' ?τ'" using sub2
    by(auto simp add: hyperset_defs tyi'_def intro!: tyl_antimono)
  also
  let 3 = "tyi' (T1 # ST) E ?A1"
  let ?g2 = "Goto(int (size (compE2 e2) + 1))"
  from sub1 have "P,Tr,mxs,size(compE2 e2)+2,[]  ?g2,0 :: 3#(2#?τs2)@[?τ']"
    by(cases "length (compE2 e2)")
      (auto simp: hyperset_defs wt_defs nth_Cons tyi'_def neq_Nil_conv
             split:nat.split intro!: tyl_antimono)
  also let ?τs1 = "compT E ?A0 ST e1"
  have "PROP ?P e1 E T1 ?A0 ST" by fact
  hence " compE2 e1,compxE2 e1 0 (size ST) [::] 2 # ?τs1 @ [3]"
    using Cond.prems wt1 by(auto simp add:after_def)
  also
  let ?τs12 = "2 # ?τs1 @ 3 # (2 # ?τs2) @ [?τ']"
  let 1 = "tyi' (Boolean#ST) E ?A0"
  let ?g1 = "IfFalse(int (size (compE2 e1) + 2))"
  let ?code = "compE2 e1 @ ?g2 # compE2 e2"
  have " [?g1],[] [::] [1] @ ?τs12"
    by(simp add: wt_IfFalse nat_add_distrib split:nat_diff_split)
  also (wt_instrs_ext2) have "[1] @ ?τs12 = 1 # ?τs12" by simp also
  let  = "tyi' ST E A"
  have "PROP ?P e E Boolean A ST" by fact
  hence " compE2 e, compxE2 e 0 (size ST) [::]  # compT E A ST e @ [1]"
    using Cond.prems wte by(auto simp add:after_def)
  finally show ?case using wte wt1 wt2 by(simp add:after_def hyperUn_assoc)
next
  case (Call E A ST e M es)
  from P,E ⊢1 eM(es) :: T
  obtain U C D Ts m Ts'
    where C: "P,E ⊢1 e :: U"
    and icto: "class_type_of' U = C"
    and "method": "P  C sees M:Ts  T = m in D"
    and wtes: "P,E ⊢1 es [::] Ts'" and subs: "P  Ts' [≤] Ts"
    by(cases) auto
  from wtes have same_size: "size es = size Ts'" by(rule WTs1_same_size)
  let ?A0 = "A  𝒜 e" let ?A1 = "?A0  𝒜s es"
  let  = "tyi' ST E A" let ?τse = "compT E A ST e"
  let e = "tyi' (U # ST) E ?A0"
  let ?τses = "compTs E ?A0 (U # ST) es"
  let 1 = "tyi' (rev Ts' @ U # ST) E ?A1"
  let ?τ' = "tyi' (T # ST) E ?A1"
  have " [Invoke M (size es)],[] [::] [1,?τ']"
    by(rule wt_Invoke[OF same_size icto "method" subs])
  also
  from Call.hyps(2)[of Ts'] Call.prems wtes C
  have " compEs2 es,compxEs2 es 0 (size ST+1) [::] e # ?τses"
    "last (e # ?τses) = 1"
    by(auto simp add:after_def)
  also have "(e # ?τses) @ [?τ'] = e # ?τses @ [?τ']" by simp
  also have " compE2 e,compxE2 e 0 (size ST) [::]  # ?τse @ [e]"
    using Call C by(auto simp add:after_def)
  finally show ?case using Call.prems C
    by(simp add:after_def hyperUn_assoc shift_compxEs2 stack_xlift_compxEs2 del: compxEs2_stack_xlift_convs compxEs2_size_convs)
next
  case Seq thus ?case
    by(auto simp:after_def)
      (fastforce simp:wt_Push wt_Pop hyperUn_assoc
                intro:wt_instrs_app2 wt_instrs_Cons)
next
  case (NewArray E A ST Ta e)
  from P,E ⊢1 newA Tae :: T
  have " [NewArray Ta], [] [::] [tyi' (Integer # ST) E (A  𝒜 e), tyi' (Ta⌊⌉ # ST) E (A  𝒜 e)]"
    by(auto simp:hyperset_defs tyi'_def wt_defs tyl_def)
  with NewArray show ?case by(auto simp: after_def intro: wt_instrs_app3)
next
  case (ALen E A ST exp)
  { fix T
    have " [ALength], [] [::] [tyi' (T⌊⌉ # ST) E (A  𝒜 exp), tyi' (Integer # ST) E (A  𝒜 exp)]"
      by(auto simp:hyperset_defs tyi'_def wt_defs tyl_def) }
  with ALen show ?case by(auto simp add: after_def)(rule wt_instrs_app2, auto)
next
  case (AAcc E A ST a i)
  from P,E ⊢1 ai :: T have wta: "P,E ⊢1 a :: T⌊⌉" and wti: "P,E ⊢1 i :: Integer" by auto
  let ?A1 = "A  𝒜 a" let ?A2 = "?A1  𝒜 i"  
  let  = "tyi' ST E A" let ?τsa = "compT E A ST a"
  let ?τ1 = "tyi' (T⌊⌉#ST) E ?A1" let ?τsi = "compT E ?A1 (T⌊⌉#ST) i"
  let ?τ2 = "tyi' (Integer#T⌊⌉#ST) E ?A2" let ?τ' = "tyi' (T#ST) E ?A2"
  have " [ALoad], [] [::] [?τ2,?τ']" by(auto simp add: tyi'_def wt_defs)
  also from AAcc.hyps(2)[of Integer] AAcc.prems wti wta
  have " compE2 i, compxE2 i 0 (size ST+1) [::] ?τ1#?τsi@[?τ2]"
    by(auto simp add: after_def)
  also from wta AAcc have " compE2 a, compxE2 a 0 (size ST) [::] #?τsa@[?τ1]" 
    by(auto simp add: after_def)
  finally show ?case using wta wti P,E ⊢1 ai :: T by(simp add: after_def hyperUn_assoc)
next
  case (AAss E A ST a i e)
  note wt = P,E ⊢1 ai := e :: T
  then obtain Ta U where wta: "P,E ⊢1 a :: Ta⌊⌉" and wti: "P,E ⊢1 i :: Integer"
    and wte: "P,E ⊢1 e :: U" and U: "P  U  Ta" and [simp]: "T = Void" by auto
  let ?A1 = "A  𝒜 a" let ?A2 = "?A1  𝒜 i" let ?A3 = "?A2  𝒜 e"
  let  = "tyi' ST E A" let ?τsa = "compT E A ST a"
  let ?τ1 = "tyi' (Ta⌊⌉#ST) E ?A1" let ?τsi = "compT E ?A1 (Ta⌊⌉#ST) i"
  let ?τ2 = "tyi' (Integer#Ta⌊⌉#ST) E ?A2" let ?τse = "compT E ?A2 (Integer#Ta⌊⌉#ST) e"
  let ?τ3 = "tyi' (U#Integer#Ta⌊⌉#ST) E ?A3" let ?τ4 = "tyi' ST E ?A3"
  let ?τ' = "tyi' (Void#ST) E ?A3"
  from ‹length ST + max_stack (ai := e)  mxs
  have " [AStore, Push Unit], [] [::] [?τ3,?τ4,?τ']"
    by(auto simp add: tyi'_def wt_defs nth_Cons split: nat.split)
  also from AAss.hyps(3)[of U] wte AAss.prems wta wti
  have " compE2 e, compxE2 e 0 (size ST+2) [::] ?τ2#?τse@[?τ3]"
    by(auto simp add: after_def)
  also from AAss.hyps(2)[of Integer] wti wta AAss.prems
  have " compE2 i, compxE2 i 0 (size ST+1) [::] ?τ1#?τsi@[?τ2]"
    by(auto simp add: after_def)
  also from wta AAss have " compE2 a, compxE2 a 0 (size ST) [::] #?τsa@[?τ1]" 
    by(auto simp add: after_def)
  finally show ?case using wta wti wte P,E ⊢1 ai := e :: T
    by(simp add: after_def hyperUn_assoc)
next
  case (CompareAndSwap E A ST e1 D F e2 e3)
  note wt = P,E ⊢1 e1∙compareAndSwap(DF, e2, e3) :: T
  then obtain T1 T2 T3 C fm T' where [simp]: "T = Boolean"
    and wt1: "P,E ⊢1 e1 :: T1" "class_type_of' T1 = C" "P  C sees F:T' (fm) in D" "volatile fm"
    and wt2: "P,E ⊢1 e2 :: T2" "P  T2  T'" and wt3: "P,E ⊢1 e3 :: T3" "P  T3  T'"
    by auto
  let ?A1 = "A  𝒜 e1" let ?A2 = "?A1  𝒜 e2" let ?A3 = "?A2  𝒜 e3"
  let  = "tyi' ST E A" let ?τs1 = "compT E A ST e1"
  let ?τ1 = "tyi' (T1#ST) E ?A1" let ?τs2 = "compT E ?A1 (T1#ST) e2"
  let ?τ2 = "tyi' (T2#T1#ST) E ?A2" let ?τs3 = "compT E ?A2 (T2#T1#ST) e3"
  let ?τ3 = "tyi' (T3#T2#T1#ST) E ?A3"
  let ?τ' = "tyi' (Boolean#ST) E ?A3"
  from ‹length ST + max_stack (e1∙compareAndSwap(DF, e2, e3))  mxs
  have " [CAS F D], [] [::] [?τ3,?τ']" using wt1 wt2 wt3
    by(cases T1)(auto simp add: tyi'_def wt_defs nth_Cons split: nat.split intro: sees_field_idemp widen_trans[OF widen_array_object] dest: sees_field_decl_above)
  also from CompareAndSwap.hyps(3)[of T3] wt3 CompareAndSwap.prems wt1 wt2
  have " compE2 e3, compxE2 e3 0 (size ST+2) [::] ?τ2#?τs3@[?τ3]"
    by(auto simp add: after_def)
  also from CompareAndSwap.hyps(2)[of T2] wt2 wt1 CompareAndSwap.prems
  have " compE2 e2, compxE2 e2 0 (size ST+1) [::] ?τ1#?τs2@[?τ2]"
    by(auto simp add: after_def)
  also from wt1 CompareAndSwap have " compE2 e1, compxE2 e1 0 (size ST) [::] #?τs1@[?τ1]" 
    by(auto simp add: after_def)
  also have "ty E (e1∙compareAndSwap(DF, e2, e3)) = T" using wt by(rule ty_def2)
  ultimately show ?case using wt1 wt2 wt3
    by(simp add: after_def hyperUn_assoc)
next
  case (InSynchronized i a exp) thus ?case by auto
qed

end

lemma states_compP [simp]: "states (compP f P) mxs mxl = states P mxs mxl"
by (simp add: JVM_states_unfold)

lemma [simp]: "appi (i, compP f P, pc, mpc, T, τ) = appi (i, P, pc, mpc, T, τ)"
proof -
  { fix ST LT
    have "appi (i, compP f P, pc, mpc, T, (ST, LT)) = appi (i, P, pc, mpc, T, (ST, LT))"
    proof(cases i)
      case (Invoke M n)
      have "C Ts D. (T m. compP f P  C sees M: TsT = m in D)  (T m. P  C sees M: TsT = m in D)"
        by(auto dest!: sees_method_compPD dest: sees_method_compP)
      with Invoke show ?thesis by clarsimp
    qed(simp_all) }
  thus ?thesis by(cases τ) simp
qed

  
lemma [simp]: "is_relevant_entry (compP f P) i = is_relevant_entry P i"
  apply (rule ext)+
  apply (unfold is_relevant_entry_def)
  apply (cases i)
  apply auto
  done

lemma [simp]: "relevant_entries (compP f P) i pc xt = relevant_entries P i pc xt"
by (simp add: relevant_entries_def)

lemma [simp]: "app i (compP f P) mpc T pc mxl xt τ = app i P mpc T pc mxl xt τ"
  apply (simp add: app_def xcpt_app_def eff_def xcpt_eff_def norm_eff_def)
  apply (fastforce simp add: image_def)
  done

lemma [simp]: "app i P mpc T pc mxl xt τ  eff i (compP f P) pc xt τ = eff i P pc xt τ"
  apply (clarsimp simp add: eff_def norm_eff_def xcpt_eff_def app_def)
  apply (cases i)
  apply(auto)
  done

lemma [simp]: "widen (compP f P) = widen P"
  apply (rule ext)+
  apply (simp)
  done
  
lemma [simp]: "compP f P  τ ≤' τ' = P  τ ≤' τ'"
by (simp add: sup_state_opt_def sup_state_def sup_ty_opt_def)(*>*)

lemma [simp]: "compP f P,T,mpc,mxl,xt  i,pc :: τs = P,T,mpc,mxl,xt  i,pc :: τs"
by (simp add: wt_instr_def cong: conj_cong)

declare TC0.compT_sizes[simp]  TC1.ty_def2[OF TC1.intro, simp]

lemma compT_method:
  fixes e and A and C and Ts and mxl0
  defines [simp]: "E  Class C # Ts"
      and [simp]: "A  {..size Ts}"
      and [simp]: "A'  A  𝒜 e"
      and [simp]: "mxs  max_stack e"
      and [simp]: "mxl0  max_vars e"
      and [simp]: "mxl  1 + size Ts + mxl0"
  assumes wf_prog: "wf_prog p P"
  shows " P,E ⊢1 e :: T; 𝒟 e A;e (size E); set E  types P; P  T  T'  
   wt_method (compP2 P) C Ts T' mxs mxl0 (compE2 e @ [Return]) (compxE2 e 0 0)
      (TC0.tyi' mxl [] E A # TC0.compTa P mxl E A [] e)"
using wf_prog
apply(simp add:wt_method_def TC0.compTa_def TC0.after_def compP2_def compMb2_def)
apply(rule conjI)
 apply(simp add:check_types_def TC0.OK_tyi'_in_statesI)
 apply(rule conjI)
  apply(frule WT1_is_type[OF wf_prog])
   apply simp
  apply(insert max_stack1[of e])
  apply(fastforce intro!: TC0.OK_tyi'_in_statesI)
 apply(erule (1) TC1.compT_states[OF TC1.intro])
    apply simp
   apply simp
  apply simp
 apply simp
apply(rule conjI)
 apply(fastforce simp add:wt_start_def TC0.tyi'_def TC0.tyl_def list_all2_conv_all_nth nth_Cons split:nat.split dest:less_antisym)
apply (frule (1) TC3.compT_wt_instrs[OF TC3.intro[OF TC1.intro], where ST = "[]" and mxs = "max_stack e" and mxl = "1 + size Ts + max_vars e"])
     apply simp
    apply simp
   apply simp
  apply simp
 apply simp
apply (clarsimp simp:TC2.wt_instrs_def TC0.after_def)
apply(rule conjI)
 apply (fastforce)
apply(clarsimp)
apply(drule (1) less_antisym)
apply(thin_tac "x. P x" for P)
apply(clarsimp simp:TC2.wt_defs xcpt_app_pcs xcpt_eff_pcs TC0.tyi'_def)
done
(*>*)


definition compTP :: "'addr J1_prog  tyP"
where
  "compTP P C M  
  let (D,Ts,T,meth) = method P C M;
       e = the meth;
       E = Class C # Ts;
       A = {..size Ts};
       mxl = 1 + size Ts + max_vars e
  in  (TC0.tyi' mxl [] E A # TC0.compTa P mxl E A [] e)"

theorem wt_compTP_compP2:
  "wf_J1_prog P  wf_jvm_progcompTP P (compP2 P)"
  apply (simp add: wf_jvm_prog_phi_def compP2_def compMb2_def)
  apply (rule wf_prog_compPI)
   prefer 2 apply assumption
  apply (clarsimp simp add: wf_mdecl_def)
  apply (simp add: compTP_def)
  apply (rule compT_method [simplified compP2_def compMb2_def, simplified])
       apply assumption+
    apply (drule (1) sees_wf_mdecl)
    apply (simp add: wf_mdecl_def)
   apply (fastforce intro: sees_method_is_class)
  apply assumption
  done


theorem wt_compP2:
  "wf_J1_prog P  wf_jvm_prog (compP2 P)"
by(auto simp add: wf_jvm_prog_def intro: wt_compTP_compP2)

end

Theory JVMTau

(*  Title:      JinjaThreads/Compiler/Tau.thy
    Author:     Andreas Lochbihler
*)

section ‹Unobservable steps for the JVM›

theory JVMTau imports
  TypeComp
  "../JVM/JVMThreaded"
  "../Framework/FWLTS"
begin

declare nth_append [simp del]
declare Listn.lesub_list_impl_same_size[simp del]
declare listE_length [simp del]

declare match_ex_table_append_not_pcs[simp del]
  outside_pcs_not_matches_entry [simp del]
  outside_pcs_compxE2_not_matches_entry [simp del]
  outside_pcs_compxEs2_not_matches_entry [simp del]

context JVM_heap_base begin

primrec τinstr :: "'m prog  'heap  'addr val list  'addr instr  bool"
where
  "τinstr P h stk (Load n) = True"
| "τinstr P h stk (Store n) = True"
| "τinstr P h stk (Push v) = True"
| "τinstr P h stk (New C) = False"
| "τinstr P h stk (NewArray T) = False"
| "τinstr P h stk ALoad = False"
| "τinstr P h stk AStore = False"
| "τinstr P h stk ALength = False"
| "τinstr P h stk (Getfield F D) = False"
| "τinstr P h stk (Putfield F D) = False"
| "τinstr P h stk (CAS F D) = False"
| "τinstr P h stk (Checkcast T) = True"
| "τinstr P h stk (Instanceof T) = True"
| "τinstr P h stk (Invoke M n) = 
   (n < length stk  
    (stk ! n = Null  
     (T Ts Tr D. typeof_addr h (the_Addr (stk ! n)) = T  P  class_type_of T sees M:TsTr = Native in D  τexternal_defs D M)))"
| "τinstr P h stk Return = True"
| "τinstr P h stk Pop = True"
| "τinstr P h stk Dup = True"
| "τinstr P h stk Swap = True"
| "τinstr P h stk (BinOpInstr bop) = True"
| "τinstr P h stk (Goto i) = True"
| "τinstr P h stk (IfFalse i) = True" 
| "τinstr P h stk ThrowExc = True"
| "τinstr P h stk MEnter = False"
| "τinstr P h stk MExit = False"

inductive τmove2 :: "'m prog  'heap  'addr val list  'addr expr1  nat  'addr option  bool"
  and τmoves2 :: "'m prog  'heap  'addr val list  'addr expr1 list  nat  'addr option  bool"
for P :: "'m prog" and h :: 'heap and stk :: "'addr val list"
where
  τmove2xcp: "pc < length (compE2 e)  τmove2 P h stk e pc xcp"

| τmove2NewArray: "τmove2 P h stk e pc xcp  τmove2 P h stk (newA Te) pc xcp"

| τmove2Cast: "τmove2 P h stk e pc xcp  τmove2 P h stk (Cast T e) pc xcp"
| τmove2CastRed: "τmove2 P h stk (Cast T e) (length (compE2 e)) None"

| τmove2InstanceOf: "τmove2 P h stk e pc xcp  τmove2 P h stk (e instanceof T) pc xcp"
| τmove2InstanceOfRed: "τmove2 P h stk (e instanceof T) (length (compE2 e)) None"

| τmove2Val: "τmove2 P h stk (Val v) 0 None"

| τmove2BinOp1:
  "τmove2 P h stk e1 pc xcp  τmove2 P h stk (e1«bop»e2) pc xcp"
| τmove2BinOp2:
  "τmove2 P h stk e2 pc xcp  τmove2 P h stk (e1«bop»e2) (length (compE2 e1) + pc) xcp"
| τmove2BinOp:
  "τmove2 P h stk (e1«bop»e2) (length (compE2 e1) + length (compE2 e2)) None"

| τmove2Var:
  "τmove2 P h stk (Var V) 0 None"

| τmove2LAss:
  "τmove2 P h stk e pc xcp  τmove2 P h stk (V:=e) pc xcp"
| τmove2LAssRed1:
  "τmove2 P h stk (V:=e) (length (compE2 e)) None"
| τmove2LAssRed2:  "τmove2 P h stk (V:=e) (Suc (length (compE2 e))) None"

| τmove2AAcc1: "τmove2 P h stk a pc xcp  τmove2 P h stk (ai) pc xcp"
| τmove2AAcc2: "τmove2 P h stk i pc xcp  τmove2 P h stk (ai) (length (compE2 a) + pc) xcp"

| τmove2AAss1: "τmove2 P h stk a pc xcp  τmove2 P h stk (ai := e) pc xcp"
| τmove2AAss2: "τmove2 P h stk i pc xcp  τmove2 P h stk (ai := e) (length (compE2 a) + pc) xcp"
| τmove2AAss3: "τmove2 P h stk e pc xcp  τmove2 P h stk (ai := e) (length (compE2 a) + length (compE2 i) + pc) xcp"
| τmove2AAssRed: "τmove2 P h stk (ai := e) (Suc (length (compE2 a) + length (compE2 i) + length (compE2 e))) None"

| τmove2ALength: "τmove2 P h stk a pc xcp  τmove2 P h stk (a∙length) pc xcp"

| τmove2FAcc: "τmove2 P h stk e pc xcp  τmove2 P h stk (eF{D}) pc xcp"

| τmove2FAss1: "τmove2 P h stk e pc xcp  τmove2 P h stk (eF{D} := e') pc xcp"
| τmove2FAss2: "τmove2 P h stk e' pc xcp  τmove2 P h stk (eF{D} := e') (length (compE2 e) + pc) xcp"
| τmove2FAssRed: "τmove2 P h stk (eF{D} := e') (Suc (length (compE2 e) + length (compE2 e'))) None"

| τmove2CAS1: "τmove2 P h stk e pc xcp  τmove2 P h stk (e∙compareAndSwap(DF, e', e'')) pc xcp"
| τmove2CAS2: "τmove2 P h stk e' pc xcp  τmove2 P h stk (e∙compareAndSwap(DF, e', e'')) (length (compE2 e) + pc) xcp"
| τmove2CAS3: "τmove2 P h stk e'' pc xcp  τmove2 P h stk (e∙compareAndSwap(DF, e', e'')) (length (compE2 e) + length (compE2 e') + pc) xcp"

| τmove2CallObj:
  "τmove2 P h stk obj pc xcp  τmove2 P h stk (objM(ps)) pc xcp"
| τmove2CallParams:
  "τmoves2 P h stk ps pc xcp  τmove2 P h stk (objM(ps)) (length (compE2 obj) + pc) xcp"
| τmove2Call:
  " length ps < length stk;
     stk ! length ps = Null  
     (T Ts Tr D. typeof_addr h (the_Addr (stk ! length ps)) = T  P  class_type_of T sees M:TsTr = Native in D  τexternal_defs D M)
   τmove2 P h stk (objM(ps)) (length (compE2 obj) + length (compEs2 ps)) None"

| τmove2BlockSome1:
  "τmove2 P h stk {V:T=v; e} 0 None"
| τmove2BlockSome2:
  "τmove2 P h stk {V:T=v; e} (Suc 0) None"
| τmove2BlockSome:
  "τmove2 P h stk e pc xcp  τmove2 P h stk {V:T=v; e} (Suc (Suc pc)) xcp"
| τmove2BlockNone:
  "τmove2 P h stk e pc xcp  τmove2 P h stk {V:T=None; e} pc xcp"

| τmove2Sync1:
  "τmove2 P h stk o' pc xcp  τmove2 P h stk (syncV (o') e) pc xcp"
| τmove2Sync2:
  "τmove2 P h stk (syncV (o') e) (length (compE2 o')) None"
| τmove2Sync3:
  "τmove2 P h stk (syncV (o') e) (Suc (length (compE2 o'))) None"
| τmove2Sync4:
  "τmove2 P h stk e pc xcp  τmove2 P h stk (syncV (o') e) (Suc (Suc (Suc (length (compE2 o') + pc)))) xcp"
| τmove2Sync5:
  "τmove2 P h stk (syncV (o') e) (Suc (Suc (Suc (length (compE2 o') + length (compE2 e))))) None"
| τmove2Sync6:
  "τmove2 P h stk (syncV (o') e) (5 + length (compE2 o') + length (compE2 e)) None"
| τmove2Sync7:
  "τmove2 P h stk (syncV (o') e) (6 + length (compE2 o') + length (compE2 e)) None"
| τmove2Sync8:
  "τmove2 P h stk (syncV (o') e) (8 + length (compE2 o') + length (compE2 e)) None"

(* This is only because compE2 produces @{term "Goto 1"} for insync expressions. *)
| τmove2InSync: "τmove2 P h stk (insyncV (a) e) 0 None"

| τmove2Seq1:
  "τmove2 P h stk e pc xcp  τmove2 P h stk (e;;e') pc xcp"
| τmove2SeqRed:
  "τmove2 P h stk (e;;e') (length (compE2 e)) None"
| τmove2Seq2:
  "τmove2 P h stk e' pc xcp  τmove2 P h stk (e;;e') (Suc (length (compE2 e) + pc)) xcp"

| τmove2Cond:
  "τmove2 P h stk e pc xcp  τmove2 P h stk (if (e) e1 else e2) pc xcp"
| τmove2CondRed:
  "τmove2 P h stk (if (e) e1 else e2) (length (compE2 e)) None"
| τmove2CondThen:
  "τmove2 P h stk e1 pc xcp
   τmove2 P h stk (if (e) e1 else e2) (Suc (length (compE2 e) + pc)) xcp"
| τmove2CondThenExit:
  "τmove2 P h stk (if (e) e1 else e2) (Suc (length (compE2 e) + length (compE2 e1))) None "
| τmove2CondElse:
  "τmove2 P h stk e2 pc xcp
   τmove2 P h stk (if (e) e1 else e2) (Suc (Suc (length (compE2 e) + length (compE2 e1) + pc))) xcp "

| τmove2While1:
  "τmove2 P h stk c pc xcp  τmove2 P h stk (while (c) e) pc xcp"
| τmove2While2:
  "τmove2 P h stk e pc xcp  τmove2 P h stk (while (c) e) (Suc (length (compE2 c) + pc)) xcp"
| τmove2While3: ― ‹Jump back to condition›
  "τmove2 P h stk (while (c) e) (Suc (Suc (length (compE2 c) + length (compE2 e)))) None"
| τmove2While4: ― ‹last instruction: Push Unit›
  "τmove2 P h stk (while (c) e) (Suc (Suc (Suc (length (compE2 c) + length (compE2 e))))) None"
| τmove2While5: ― ‹IfFalse instruction›
  "τmove2 P h stk (while (c) e) (length (compE2 c)) None"
| τmove2While6: ― ‹Pop instruction›
  "τmove2 P h stk (while (c) e) (Suc (length (compE2 c) + length (compE2 e))) None"

| τmove2Throw1:
  "τmove2 P h stk e pc xcp  τmove2 P h stk (throw e) pc xcp"
| τmove2Throw2:
  "τmove2 P h stk (throw e) (length (compE2 e)) None"

| τmove2Try1:
  "τmove2 P h stk e pc xcp  τmove2 P h stk (try e catch(C V) e') pc xcp"
| τmove2TryJump:
  "τmove2 P h stk (try e catch(C V) e') (length (compE2 e)) None"
| τmove2TryCatch2:
  "τmove2 P h stk (try e catch(C V) e') (Suc (length (compE2 e))) None"
| τmove2Try2:
  "τmove2 P h stk {V:T=None; e'} pc xcp
   τmove2 P h stk (try e catch(C V) e') (Suc (Suc (length (compE2 e) + pc))) xcp"

| τmoves2Hd:
  "τmove2 P h stk e pc xcp  τmoves2 P h stk (e # es) pc xcp"
| τmoves2Tl:
  "τmoves2 P h stk es pc xcp  τmoves2 P h stk (e # es) (length (compE2 e) + pc) xcp"

inductive_cases τmove2_cases:
  "τmove2 P h stk (new C) pc xcp"
  "τmove2 P h stk (newA Te) pc xcp"
  "τmove2 P h stk (Cast T e) pc xcp"
  "τmove2 P h stk (e instanceof T) pc xcp"
  "τmove2 P h stk (Val v) pc xcp"
  "τmove2 P h stk (Var V) pc xcp"
  "τmove2 P h stk (e1«bop»e2) pc xcp"
  "τmove2 P h stk (V := e) pc xcp"
  "τmove2 P h stk (e1e2) pc xcp"
  "τmove2 P h stk (e1e2 := e3) pc xcp"
  "τmove2 P h stk (e1∙length) pc xcp"
  "τmove2 P h stk (e1F{D}) pc xcp"
  "τmove2 P h stk (e1F{D} := e3) pc xcp"
  "τmove2 P h stk (e1∙compareAndSwap(DF, e2, e3)) pc xcp"
  "τmove2 P h stk (eM(ps)) pc xcp"
  "τmove2 P h stk {V:T=vo; e} pc xcp"
  "τmove2 P h stk (syncV (e1) e2) pc xcp"
  "τmove2 P h stk (e1;;e2) pc xcp"
  "τmove2 P h stk (if (e1) e2 else e3) pc xcp"
  "τmove2 P h stk (while (e1) e2) pc xcp"
  "τmove2 P h stk (try e1 catch(C V) e2) pc xcp"
  "τmove2 P h stk (throw e) pc xcp"

lemma τmoves2xcp: "pc < length (compEs2 es)  τmoves2 P h stk es pc xcp"
proof(induct es arbitrary: pc)
  case Nil thus ?case by simp
next
  case (Cons e es)
  note IH = pc. pc < length (compEs2 es)  τmoves2 P h stk es pc xcp
  note pc = pc < length (compEs2 (e # es))
  show ?case
  proof(cases "pc < length (compE2 e)")
    case True
    thus ?thesis by(auto intro: τmoves2Hd τmove2xcp)
  next
    case False
    with pc IH[of "pc - length (compE2 e)"]
    have "τmoves2 P h stk es (pc - length (compE2 e)) xcp" by(simp)
    hence "τmoves2 P h stk (e # es) (length (compE2 e) + (pc - length (compE2 e))) xcp"
      by(rule τmoves2Tl)
    with False show ?thesis by simp
  qed
qed

lemma τmove2_intros':
  shows τmove2CastRed': "pc = length (compE2 e)  τmove2 P h stk (Cast T e) pc None"
  and τmove2InstanceOfRed': "pc = length (compE2 e)  τmove2 P h stk (e instanceof T) pc None"
  and τmove2BinOp2': " τmove2 P h stk e2 pc xcp; pc' = length (compE2 e1) + pc   τmove2 P h stk (e1«bop»e2) pc' xcp"
  and τmove2BinOp': "pc = length (compE2 e1) + length (compE2 e2)  τmove2 P h stk (e1«bop»e2) pc None"
  and τmove2LAssRed1': "pc = length (compE2 e)  τmove2 P h stk (V:=e) pc None"
  and τmove2LAssRed2': "pc = Suc (length (compE2 e))  τmove2 P h stk (V:=e) pc None"
  and τmove2AAcc2': " τmove2 P h stk i pc xcp; pc' = length (compE2 a) + pc   τmove2 P h stk (ai) pc' xcp"
  and τmove2AAss2': " τmove2 P h stk i pc xcp; pc' = length (compE2 a) + pc   τmove2 P h stk (ai := e) pc' xcp"
  and τmove2AAss3': " τmove2 P h stk e pc xcp; pc' = length (compE2 a) + length (compE2 i) + pc   τmove2 P h stk (ai := e) pc' xcp"
  and τmove2AAssRed': "pc = Suc (length (compE2 a) + length (compE2 i) + length (compE2 e))  τmove2 P h stk (ai := e) pc None"
  and τmove2FAss2': " τmove2 P h stk e' pc xcp; pc' = length (compE2 e) + pc   τmove2 P h stk (eF{D} := e') pc' xcp"
  and τmove2FAssRed': "pc = Suc (length (compE2 e) + length (compE2 e'))  τmove2 P h stk (eF{D} := e') pc None"
  and τmove2CAS2': " τmove2 P h stk e2 pc xcp; pc' = length (compE2 e1) + pc   τmove2 P h stk (e1∙compareAndSwap(DF, e2, e3)) pc' xcp"
  and τmove2CAS3': " τmove2 P h stk e3 pc xcp; pc' = length (compE2 e1) + length (compE2 e2) + pc   τmove2 P h stk (e1∙compareAndSwap(DF, e2, e3)) pc' xcp"
  and τmove2CallParams': " τmoves2 P h stk ps pc xcp; pc' = length (compE2 obj) + pc   τmove2 P h stk (objM(ps)) pc' xcp"
  and τmove2Call': " pc = length (compE2 obj) + length (compEs2 ps); length ps < length stk; 
                     stk ! length ps = Null  
                     (T Ts Tr D. typeof_addr h (the_Addr (stk ! length ps)) = T  P  class_type_of T sees M:TsTr = Native in D  τexternal_defs D M) 
                    τmove2 P h stk (objM(ps)) pc None"
  and τmove2BlockSome2: "pc = Suc 0  τmove2 P h stk {V:T=v; e} pc None"
  and τmove2BlockSome': " τmove2 P h stk e pc xcp; pc' = Suc (Suc pc)   τmove2 P h stk {V:T=v; e} pc' xcp"
  and τmove2Sync2': "pc = length (compE2 o')  τmove2 P h stk (syncV (o') e) pc None"
  and τmove2Sync3': "pc = Suc (length (compE2 o'))  τmove2 P h stk (syncV (o') e) pc None"
  and τmove2Sync4': " τmove2 P h stk e pc xcp; pc' = Suc (Suc (Suc (length (compE2 o') + pc)))   τmove2 P h stk (syncV (o') e) pc' xcp"
  and τmove2Sync5': "pc = Suc (Suc (Suc (length (compE2 o') + length (compE2 e))))  τmove2 P h stk (syncV (o') e) pc None"
  and τmove2Sync6': "pc = 5 + length (compE2 o') + length (compE2 e)  τmove2 P h stk (syncV (o') e) pc None"
  and τmove2Sync7': "pc = 6 + length (compE2 o') + length (compE2 e)  τmove2 P h stk (syncV (o') e) pc None"
  and τmove2Sync8': "pc = 8 + length (compE2 o') + length (compE2 e)  τmove2 P h stk (syncV (o') e) pc None"
  and τmove2SeqRed': "pc = length (compE2 e)  τmove2 P h stk (e;;e') pc None"
  and τmove2Seq2': " τmove2 P h stk e' pc xcp; pc' = Suc (length (compE2 e) + pc)   τmove2 P h stk (e;;e') pc' xcp"
  and τmove2CondRed': "pc = length (compE2 e)  τmove2 P h stk (if (e) e1 else e2) pc None"
  and τmove2CondThen': " τmove2 P h stk e1 pc xcp; pc' = Suc (length (compE2 e) + pc)   τmove2 P h stk (if (e) e1 else e2) pc' xcp"
  and τmove2CondThenExit': "pc = Suc (length (compE2 e) + length (compE2 e1))  τmove2 P h stk (if (e) e1 else e2) pc None"
  and τmove2CondElse': " τmove2 P h stk e2 pc xcp; pc' = Suc (Suc (length (compE2 e) + length (compE2 e1) + pc))  
                         τmove2 P h stk (if (e) e1 else e2) pc' xcp"
  and τmove2While2': " τmove2 P h stk e pc xcp; pc' = Suc (length (compE2 c) + pc)   τmove2 P h stk (while (c) e) pc' xcp"
  and τmove2While3': "pc = Suc (Suc (length (compE2 c) + length (compE2 e)))  τmove2 P h stk (while (c) e) pc None"
  and τmove2While4': "pc = Suc (Suc (Suc (length (compE2 c) + length (compE2 e))))  τmove2 P h stk (while (c) e) pc None"
  and τmove2While5': "pc = length (compE2 c)  τmove2 P h stk (while (c) e) pc None"
  and τmove2While6': "pc = Suc (length (compE2 c) + length (compE2 e))  τmove2 P h stk (while (c) e) pc None"
  and τmove2Throw2': "pc = length (compE2 e)  τmove2 P h stk (throw e) pc None"
  and τmove2TryJump': "pc = length (compE2 e)  τmove2 P h stk (try e catch(C V) e') pc None"
  and τmove2TryCatch2': "pc = Suc (length (compE2 e))  τmove2 P h stk (try e catch(C V) e') pc None"
  and τmove2Try2': " τmove2 P h stk {V:T=None; e'} pc xcp; pc' = Suc (Suc (length (compE2 e) + pc)) 
                     τmove2 P h stk (try e catch(C V) e') pc' xcp"
  and τmoves2Tl': " τmoves2 P h stk es pc xcp; pc' = length (compE2 e) + pc   τmoves2 P h stk (e # es) pc' xcp"
apply(blast intro: τmove2_τmoves2.intros)+
done

lemma τmove2_iff: "τmove2 P h stk e pc xcp  pc < length (compE2 e)  (xcp = None  τinstr P h stk (compE2 e ! pc))" (is "?lhs1  ?rhs1")
  and τmoves2_iff: "τmoves2 P h stk es pc xcp  pc < length (compEs2 es)  (xcp = None  τinstr P h stk (compEs2 es ! pc))" (is "?lhs2  ?rhs2")
proof -
  have rhs1lhs1: " τinstr P h stk (compE2 e ! pc); pc < length (compE2 e)   τmove2 P h stk e pc None"
    and rhs2lhs2: " τinstr P h stk (compEs2 es ! pc); pc < length (compEs2 es)   τmoves2 P h stk es pc None"
    apply(induct e and es arbitrary: pc and pc rule: compE2.induct compEs2.induct)
    apply(force intro: τmove2_τmoves2.intros τmove2_intros' simp add: nth_append nth_Cons' not_less_eq split: if_split_asm)+
    done

  { assume "pc < length (compE2 e)" "xcp  None"
    hence "τmove2 P h stk e pc xcp" by(auto intro: τmove2xcp) }
  with rhs1lhs1 have "?rhs1  ?lhs1" by(cases xcp) auto
  moreover {
    assume "pc < length (compEs2 es)" "xcp  None"
    hence "τmoves2 P h stk es pc xcp" by(auto intro: τmoves2xcp) }
  with rhs2lhs2 have "?rhs2  ?lhs2" by(cases xcp) auto
  moreover have "?lhs1  ?rhs1" and "?lhs2  ?rhs2"
    by(induct rule: τmove2_τmoves2.inducts)(fastforce simp add: nth_append eval_nat_numeral)+
  ultimately show "?lhs1  ?rhs1" "?lhs2  ?rhs2" by blast+
qed

lemma τmove2_pc_length_compE2: "τmove2 P h stk e pc xcp  pc < length (compE2 e)"
  and τmoves2_pc_length_compEs2: "τmoves2 P h stk es pc xcp  pc < length (compEs2 es)"
by(simp_all add: τmove2_iff τmoves2_iff)

lemma τmove2_pc_length_compE2_conv: "pc  length (compE2 e)  ¬ τmove2 P h stk e pc xcp"
by(auto dest: τmove2_pc_length_compE2)

lemma τmoves2_pc_length_compEs2_conv: "pc  length (compEs2 es)  ¬ τmoves2 P h stk es pc xcp"
by(auto dest: τmoves2_pc_length_compEs2)

lemma τmoves2_append [elim]:
  "τmoves2 P h stk es pc xcp  τmoves2 P h stk (es @ es') pc xcp"
by(auto simp add: τmoves2_iff nth_append)

lemma append_τmoves2:
  "τmoves2 P h stk es pc xcp  τmoves2 P h stk (es' @ es) (length (compEs2 es') + pc) xcp"
by(simp add: τmoves2_iff)

lemma [dest]:
  shows τmove2_NewArrayD: " τmove2 P h stk (newA Te) pc xcp; pc < length (compE2 e)   τmove2 P h stk e pc xcp"
  and τmove2_CastD: " τmove2 P h stk (Cast T e) pc xcp; pc < length (compE2 e)   τmove2 P h stk e pc xcp"
  and τmove2_InstanceOfD: " τmove2 P h stk (e instanceof T) pc xcp; pc < length (compE2 e)   τmove2 P h stk e pc xcp"
  and τmove2_BinOp1D: " τmove2 P h stk (e1 «bop» e2) pc' xcp'; pc' < length (compE2 e1)   τmove2 P h stk e1 pc' xcp'"
  and τmove2_BinOp2D:
  " τmove2 P h stk (e1 «bop» e2) (length (compE2 e1) + pc') xcp'; pc' < length (compE2 e2)   τmove2 P h stk e2 pc' xcp'"
  and τmove2_LAssD: " τmove2 P h stk (V := e) pc xcp; pc < length (compE2 e)   τmove2 P h stk e pc xcp"
  and τmove2_AAccD1: " τmove2 P h stk (ai) pc xcp; pc < length (compE2 a)   τmove2 P h stk a pc xcp"
  and τmove2_AAccD2: " τmove2 P h stk (ai) (length (compE2 a) + pc) xcp; pc < length (compE2 i)   τmove2 P h stk i pc xcp"
  and τmove2_AAssD1: " τmove2 P h stk (ai := e) pc xcp; pc < length (compE2 a)   τmove2 P h stk a pc xcp"
  and τmove2_AAssD2: " τmove2 P h stk (ai := e) (length (compE2 a) + pc) xcp; pc < length (compE2 i)   τmove2 P h stk i pc xcp"
  and τmove2_AAssD3:
  " τmove2 P h stk (ai := e) (length (compE2 a) + length (compE2 i) + pc) xcp; pc < length (compE2 e)   τmove2 P h stk e pc xcp"
  and τmove2_ALengthD: " τmove2 P h stk (a∙length) pc xcp; pc < length (compE2 a)   τmove2 P h stk a pc xcp"
  and τmove2_FAccD: " τmove2 P h stk (eF{D}) pc xcp; pc < length (compE2 e)   τmove2 P h stk e pc xcp"
  and τmove2_FAssD1: " τmove2 P h stk (eF{D} := e') pc xcp; pc < length (compE2 e)   τmove2 P h stk e pc xcp"
  and τmove2_FAssD2: " τmove2 P h stk (eF{D} := e') (length (compE2 e) + pc) xcp; pc < length (compE2 e')   τmove2 P h stk e' pc xcp"
  and τmove2_CASD1: " τmove2 P h stk (e1∙compareAndSwap(DF, e2, e3)) pc xcp; pc < length (compE2 e1)   τmove2 P h stk e1 pc xcp"
  and τmove2_CASD2: " τmove2 P h stk (e1∙compareAndSwap(DF, e2, e3)) (length (compE2 e1) + pc) xcp; pc < length (compE2 e2)   τmove2 P h stk e2 pc xcp"
  and τmove2_CASD3:
  " τmove2 P h stk (e1∙compareAndSwap(DF, e2, e3)) (length (compE2 e1) + length (compE2 e2) + pc) xcp; pc < length (compE2 e3)   τmove2 P h stk e3 pc xcp"
  and τmove2_CallObjD: " τmove2 P h stk (eM(es)) pc xcp; pc < length (compE2 e)   τmove2 P h stk e pc xcp"
  and τmove2_BlockNoneD: "τmove2 P h stk {V:T=None; e} pc xcp  τmove2 P h stk e pc xcp"
  and τmove2_BlockSomeD: "τmove2 P h stk {V:T=v; e} (Suc (Suc pc)) xcp  τmove2 P h stk e pc xcp"
  and τmove2_sync1D: " τmove2 P h stk (syncV (o') e) pc xcp; pc < length (compE2 o')   τmove2 P h stk o' pc xcp"
  and τmove2_sync2D:
  " τmove2 P h stk (syncV (o') e) (Suc (Suc (Suc (length (compE2 o') + pc)))) xcp; pc < length (compE2 e)   τmove2 P h stk e pc xcp"
  and τmove2_Seq1D: " τmove2 P h stk (e1;; e2) pc xcp; pc < length (compE2 e1)   τmove2 P h stk e1 pc xcp"
  and τmove2_Seq2D: "τmove2 P h stk (e1;; e2) (Suc (length (compE2 e1) + pc')) xcp'  τmove2 P h stk e2 pc' xcp'"
  and τmove2_IfCondD: " τmove2 P h stk (if (e) e1 else e2) pc xcp; pc < length (compE2 e)   τmove2 P h stk e pc xcp"
  and τmove2_IfThenD:
  " τmove2 P h stk (if (e) e1 else e2) (Suc (length (compE2 e) + pc')) xcp'; pc' < length (compE2 e1)   τmove2 P h stk e1 pc' xcp'"
  and τmove2_IfElseD:
  "τmove2 P h stk (if (e) e1 else e2) (Suc (Suc (length (compE2 e) + length (compE2 e1) + pc'))) xcp'  τmove2 P h stk e2 pc' xcp'"
  and τmove2_WhileCondD: " τmove2 P h stk (while (c) b) pc xcp; pc < length (compE2 c)   τmove2 P h stk c pc xcp"
  and τmove2_ThrowD: " τmove2 P h stk (throw e) pc xcp; pc < length (compE2 e)   τmove2 P h stk e pc xcp"
  and τmove2_Try1D: " τmove2 P h stk (try e1 catch(C' V) e2) pc xcp; pc < length (compE2 e1)   τmove2 P h stk e1 pc xcp"
apply(auto elim!: τmove2_cases intro: τmove2xcp dest: τmove2_pc_length_compE2)
done

lemma τmove2_Invoke:
  "τmove2 P h stk e pc None; compE2 e ! pc = Invoke M n 
   n < length stk  (stk ! n = Null  (T Ts Tr D. typeof_addr h (the_Addr (stk ! n)) = T  P  class_type_of T sees M:TsTr = Native in D  τexternal_defs D M))"

  and τmoves2_Invoke: 
  "τmoves2 P h stk es pc None; compEs2 es ! pc = Invoke M n  
   n < length stk  (stk ! n = Null  (T C Ts Tr D. typeof_addr h (the_Addr (stk ! n)) = T  P  class_type_of T sees M:TsTr = Native in D  τexternal_defs D M))"
by(simp_all add: τmove2_iff τmoves2_iff split_beta)

lemmas τmove2_compE2_not_Invoke = τmove2_Invoke
lemmas τmoves2_compEs2_not_Invoke = τmoves2_Invoke

lemma τmove2_blocks1 [simp]:
  "τmove2 P h stk (blocks1 n Ts body) pc' xcp' = τmove2 P h stk body pc' xcp'"
by(simp add: τmove2_iff)

lemma τinstr_stk_append:
  "τinstr P h stk i  τinstr P h (stk @ vs) i"
by(cases i)(auto simp add: nth_append)

lemma τmove2_stk_append:
  "τmove2 P h stk e pc xcp  τmove2 P h (stk @ vs) e pc xcp"
by(simp add: τmove2_iff τinstr_stk_append)

lemma τmoves2_stk_append:
  "τmoves2 P h stk es pc xcp  τmoves2 P h (stk @ vs) es pc xcp"
by(simp add: τmoves2_iff τinstr_stk_append)

fun τMove2 :: "'addr jvm_prog  ('addr, 'heap) jvm_state  bool"
where 
  "τMove2 P (xcp, h, []) = False"
| "τMove2 P (xcp, h, (stk, loc, C, M, pc) # frs) =
       (let (_,_,_,meth) = method P C M; (_,_,ins,xt) = the meth
        in (pc < length ins  (xcp = None  τinstr P h stk (ins ! pc))))"

lemma τMove2_iff:
  "τMove2 P σ = (let (xcp, h, frs) = σ
                 in case frs of []  False
     | (stk, loc, C, M, pc) # frs'  
       (let (_,_,_,meth) = method P C M; (_,_,ins,xt) = the meth
        in (pc < length ins  (xcp = None  τinstr P h stk (ins ! pc)))))"
by(cases σ)(clarsimp split: list.splits simp add: fun_eq_iff split_beta)

lemma τinstr_compP [simp]: "τinstr (compP f P) h stk i  τinstr P h stk i"
by(cases i) auto

lemma [simp]: fixes e :: "'addr expr1" and es :: "'addr expr1 list"
  shows τmove2_compP: "τmove2 (compP f P) h stk e = τmove2 P h stk e"
  and τmoves2_compP: "τmoves2 (compP f P) h stk es = τmoves2 P h stk es"
by(auto simp add: τmove2_iff τmoves2_iff fun_eq_iff)

lemma τMove2_compP2:
  "P  C sees M:TsT=body in D  
   τMove2 (compP2 P) (xcp, h, (stk, loc, C, M, pc) # frs) =
   (case xcp of None  τmove2 P h stk body pc xcp  pc = length (compE2 body) | Some a  pc < Suc (length (compE2 body)))"
by(clarsimp simp add: τmove2_iff compP2_def compMb2_def nth_append nth_Cons' split: option.splits if_split_asm)

abbreviation τMOVE2 ::
  "'addr jvm_prog  (('addr option × 'addr frame list) × 'heap, ('addr, 'thread_id, 'heap) jvm_thread_action) trsys"
where "τMOVE2 P  λ((xcp, frs), h) ta s. τMove2 P (xcp, h, frs)  ta = ε"

lemma τjvmd_heap_unchanged: 
  " P,t  Normal (xcp, h, frs) -ε-jvmd→ Normal (xcp', h', frs'); τMove2 P (xcp, h, frs) 
   h = h'"
apply(erule jvmd_NormalE)
apply(clarsimp)
apply(cases xcp)
 apply(rename_tac stk loc C M pc FRS M' Ts T meth mxs mxl ins xt)
 apply(case_tac "ins ! pc")
 prefer 19 ― ‹BinOpInstr›
 apply(rename_tac bop)
 apply(case_tac "the (binop bop (hd (tl stk)) (hd stk))")
 apply(auto simp add: split_beta τexternal_def split: if_split_asm)
apply(fastforce simp add: check_def has_method_def τexternal_def dest: τexternal_red_external_aggr_heap_unchanged)
done

lemma mexecd_τmthr_wf:
  "τmultithreaded_wf JVM_final (mexecd P) (τMOVE2 P)"
proof
  fix t x h ta x' h'
  assume "mexecd P t (x, h) ta (x', h')"
    and "τMOVE2 P (x, h) ta (x', h')"
  thus "h = h'"
    by(cases x)(cases x', auto dest: τjvmd_heap_unchanged)
next
  fix s ta s'
  assume "τMOVE2 P s ta s'" thus "ta = ε" by(simp add: split_beta)
qed

end

sublocale JVM_heap_base < execd_mthr: 
  τmultithreaded_wf 
    JVM_final
    "mexecd P"
    convert_RA
    "τMOVE2 P"
  for P
by(rule mexecd_τmthr_wf)

context JVM_heap_base begin

lemma τexec_1_taD:
  assumes exec: "exec_1_d P t (Normal (xcp, h, frs)) ta (Normal (xcp', h', frs'))"
  and τ: "τMove2 P (xcp, h, frs)"
  shows "ta = ε"
using assms
apply(auto elim!: jvmd_NormalE simp add: split_beta)
apply(cases xcp)
apply auto
apply(rename_tac stk loc C M pc FRS)
apply(case_tac "instrs_of P C M ! pc")
apply(simp_all split: if_split_asm)
apply(auto simp add: check_def has_method_def τexternal_def dest!: τexternal_red_external_aggr_TA_empty)
done

end

end

Theory Execs

(*  Title:      JinjaThreads/Compiler/Execs.thy
    Author:     Andreas Lochbihler
*)

section ‹JVM Semantics for the delay bisimulation proof from intermediate language to byte code›

theory Execs imports JVMTau begin

declare match_ex_table_app [simp del]
  match_ex_table_eq_NoneI [simp del]
  compxE2_size_convs [simp del]
  compxE2_stack_xlift_convs [simp del]
  compxEs2_stack_xlift_convs [simp del]

type_synonym
  ('addr, 'heap) check_instr' = 
  "'addr instr  'addr jvm_prog  'heap  'addr val list  'addr val list  cname  mname  pc  'addr frame list  bool"

primrec check_instr' :: "('addr, 'heap) check_instr'"
where 
check_instr'_Load:
  "check_instr' (Load n) P h stk loc C M0 pc frs =
  True"

| check_instr'_Store:
  "check_instr' (Store n) P h stk loc C0 M0 pc frs =
  (0 < length stk)"

| check_instr'_Push:
  "check_instr' (Push v) P h stk loc C0 M0 pc frs =
  True"

| check_instr'_New:
  "check_instr' (New C) P h stk loc C0 M0 pc frs = 
  True"

| check_instr'_NewArray:
  "check_instr' (NewArray T) P h stk loc C0 M0 pc frs =
  (0 < length stk)"

| check_instr'_ALoad:
  "check_instr' ALoad P h stk loc C0 M0 pc frs =
  (1 < length stk)"

| check_instr'_AStore:
  "check_instr' AStore P h stk loc C0 M0 pc frs =
  (2 < length stk)"

| check_instr'_ALength:
  "check_instr' ALength P h stk loc C0 M0 pc frs =
  (0 < length stk)"

| check_instr'_Getfield:
  "check_instr' (Getfield F C) P h stk loc C0 M0 pc frs = 
  (0 < length stk)"

| check_instr'_Putfield:
  "check_instr' (Putfield F C) P h stk loc C0 M0 pc frs = 
  (1 < length stk)"

| check_instr'_CAS:
  "check_instr' (CAS F C) P h stk loc C0 M0 pc frs  =
  (2 < length stk)"

| check_instr'_Checkcast:
  "check_instr' (Checkcast T) P h stk loc C0 M0 pc frs =
  (0 < length stk)"

| check_instr'_Instanceof:
  "check_instr' (Instanceof T) P h stk loc C0 M0 pc frs =
  (0 < length stk)"

| check_instr'_Invoke:
  "check_instr' (Invoke M n) P h stk loc C0 M0 pc frs =
  (n < length stk)"

| check_instr'_Return:
  "check_instr' Return P h stk loc C0 M0 pc frs =
  (0 < length stk)"
 
| check_instr'_Pop:
  "check_instr' Pop P h stk loc C0 M0 pc frs = 
  (0 < length stk)"

| check_instr'_Dup:
  "check_instr' Dup P h stk loc C0 M0 pc frs = 
  (0 < length stk)"

| check_instr'_Swap:
  "check_instr' Swap P h stk loc C0 M0 pc frs = 
  (1 < length stk)"

| check_instr'_BinOpInstr:
  "check_instr' (BinOpInstr bop) P h stk loc C0 M0 pc frs =
  (1 < length stk)"

| check_instr'_IfFalse:
  "check_instr' (IfFalse b) P h stk loc C0 M0 pc frs =
  (0 < length stk  0  int pc+b)"

| check_instr'_Goto:
  "check_instr' (Goto b) P h stk loc C0 M0 pc frs =
  (0  int pc+b)"

| check_instr'_Throw:
  "check_instr' ThrowExc P h stk loc C0 M0 pc frs =
  (0 < length stk)"

| check_instr'_MEnter:
  "check_instr' MEnter P h stk loc C0 M0 pc frs =
   (0 < length stk)"

| check_instr'_MExit:
  "check_instr' MExit P h stk loc C0 M0 pc frs =
   (0 < length stk)"

definition ci_stk_offer :: "('addr, 'heap) check_instr'  bool"
where
  "ci_stk_offer ci =
  (ins P h stk stk' loc C M pc frs. ci ins P h stk loc C M pc frs  ci ins P h (stk @ stk') loc C M pc frs)"

lemma ci_stk_offerI:
  "(ins P h stk stk' loc C M pc frs. ci ins P h stk loc C M pc frs  ci ins P h (stk @ stk') loc C M pc frs)  ci_stk_offer ci"
unfolding ci_stk_offer_def by blast

lemma ci_stk_offerD:
  " ci_stk_offer ci; ci ins P h stk loc C M pc frs   ci ins P h (stk @ stk') loc C M pc frs"
unfolding ci_stk_offer_def by blast


lemma check_instr'_stk_offer:
  "ci_stk_offer check_instr'"
proof(rule ci_stk_offerI)
  fix ins P h stk stk' loc C M pc frs
  assume "check_instr' ins P h stk loc C M pc frs"
  thus "check_instr' ins P h (stk @ stk') loc C M pc frs"
    by(cases ins) auto
qed

context JVM_heap_base begin

lemma check_instr_imp_check_instr':
  "check_instr ins P h stk loc C M pc frs  check_instr' ins P h stk loc C M pc frs"
by(cases ins) auto

lemma check_instr_stk_offer:
  "ci_stk_offer check_instr"
proof(rule ci_stk_offerI)
  fix ins P h stk stk' loc C M pc frs
  assume "check_instr ins P h stk loc C M pc frs"
  thus "check_instr ins P h (stk @ stk') loc C M pc frs"
    by(cases ins)(auto simp add: nth_append hd_append neq_Nil_conv tl_append split: list.split)
qed

end

(* TODO: Combine ins_jump_ok and jump_ok *)
primrec jump_ok :: "'addr instr list  nat  nat  bool"
where "jump_ok [] n n' = True"
| "jump_ok (x # xs) n n' = (jump_ok xs (Suc n) n'  
                           (case x of IfFalse m  - int n  m  m  int (n' + length xs)
                                       | Goto m  - int n  m  m  int (n' + length xs)
                                            | _  True))"

lemma jump_ok_append [simp]:
  "jump_ok (xs @ xs') n n'  jump_ok xs n (n' + length xs')  jump_ok xs' (n + length xs) n'"
apply(induct xs arbitrary: n)
 apply(simp)
apply(auto split: instr.split)
done

lemma jump_ok_GotoD:
  " jump_ok ins n n'; ins ! pc = Goto m; pc < length ins   - int (pc + n)  m  m < int (length ins - pc + n')"
apply(induct ins arbitrary: n n' pc)
 apply(simp)
apply(clarsimp)
apply(case_tac pc)
apply(fastforce)+
done

lemma jump_ok_IfFalseD:
  " jump_ok ins n n'; ins ! pc = IfFalse m; pc < length ins   - int (pc + n)  m  m < int (length ins - pc + n')"
apply(induct ins arbitrary: n n' pc)
 apply(simp)
apply(clarsimp)
apply(case_tac pc)
apply(fastforce)+
done

lemma fixes e :: "'addr expr1" and es :: "'addr expr1 list"
  shows compE2_jump_ok [intro!]: "jump_ok (compE2 e) n (Suc n')"
  and compEs2_jump_ok [intro!]: "jump_ok (compEs2 es) n (Suc n')"
apply(induct e and es arbitrary: n n' and n n' rule: compE2.induct compEs2.induct)
apply(auto split: bop.split)
done

lemma fixes e :: "'addr expr1" and es :: "'addr expr1 list"
  shows compE1_Goto_not_same: " compE2 e ! pc = Goto i; pc < length (compE2 e)   nat (int pc + i)  pc"
  and compEs2_Goto_not_same: " compEs2 es ! pc = Goto i; pc < length (compEs2 es)   nat (int pc + i)  pc"
apply(induct e and es arbitrary: pc i and pc i rule: compE2.induct compEs2.induct)
apply(auto simp add: nth_Cons nth_append split: if_split_asm bop.split_asm nat.splits)
apply fastforce+
done

fun ins_jump_ok :: "'addr instr  nat  bool"
where
  "ins_jump_ok (Goto m) l = (- (int l)  m)"
| "ins_jump_ok (IfFalse m) l = (- (int l)  m)"
| "ins_jump_ok _ _ = True"

definition wf_ci :: "('addr, 'heap) check_instr'  bool"
where
  "wf_ci ci 
   ci_stk_offer ci  ci  check_instr' 
   (ins P h stk loc C M pc pc' frs. ci ins P h stk loc C M pc frs  ins_jump_ok ins pc'  ci ins P h stk loc C M pc' frs)"

lemma wf_ciI:
  " ci_stk_offer ci;
    ins P h stk loc C M pc frs. ci ins P h stk loc C M pc frs  check_instr' ins P h stk loc C M pc frs;
    ins P h stk loc C M pc pc' frs.  ci ins P h stk loc C M pc frs; ins_jump_ok ins pc'   ci ins P h stk loc C M pc' frs 
   wf_ci ci"
unfolding wf_ci_def le_fun_def le_bool_def
by blast

lemma check_instr'_pc:
  " check_instr' ins P h stk loc C M pc frs; ins_jump_ok ins pc'   check_instr' ins P h stk loc C M pc' frs"
by(cases ins) auto

lemma wf_ci_check_instr' [iff]:
  "wf_ci check_instr'"
apply(rule wf_ciI)
  apply(rule check_instr'_stk_offer)
 apply(assumption)
apply(erule (1) check_instr'_pc)
done

lemma jump_ok_ins_jump_ok:
  " jump_ok ins n n'; pc < length ins   ins_jump_ok (ins ! pc) (pc + n)"
apply(induct ins arbitrary: n n' pc)
apply(fastforce simp add: nth_Cons' gr0_conv_Suc split: instr.split_asm)+
done

context JVM_heap_base begin

lemma check_instr_pc:
  " check_instr ins P h stk loc C M pc frs; ins_jump_ok ins pc'   check_instr ins P h stk loc C M pc' frs"
by(cases ins) auto

lemma wf_ci_check_instr [iff]:
  "wf_ci check_instr"
apply(rule wf_ciI)
  apply(rule check_instr_stk_offer)
 apply(erule check_instr_imp_check_instr')
apply(erule (1) check_instr_pc)
done

end

lemma wf_ciD1: "wf_ci ci  ci_stk_offer ci"
unfolding wf_ci_def by blast

lemma wf_ciD2: " wf_ci ci; ci ins P h stk loc C M pc frs   check_instr' ins P h stk loc C M pc frs"
unfolding wf_ci_def le_fun_def le_bool_def
by blast

lemma wf_ciD3: " wf_ci ci; ci ins P h stk loc C M pc frs; ins_jump_ok ins pc'   ci ins P h stk loc C M pc' frs"
unfolding wf_ci_def by blast

lemma check_instr'_ins_jump_ok: "check_instr' ins P h stk loc C M pc frs  ins_jump_ok ins pc"
by(cases ins) auto
lemma wf_ci_ins_jump_ok:
  assumes wf: "wf_ci ci"
  and ci: "ci ins P h stk loc C M pc frs"
  and pc': "pc  pc'"
  shows "ins_jump_ok ins pc'"
proof -
  from wf ci have "check_instr' ins P h stk loc C M pc frs" by(rule wf_ciD2)
  with pc' have "check_instr' ins P h stk loc C M pc' frs" by(cases ins) auto
  thus ?thesis by(rule check_instr'_ins_jump_ok)
qed

lemma wf_ciD3': " wf_ci ci; ci ins P h stk loc C M pc frs; pc  pc'   ci ins P h stk loc C M pc' frs"
apply(frule (2) wf_ci_ins_jump_ok)
apply(erule (2) wf_ciD3)
done

typedef ('addr, 'heap) check_instr = "Collect wf_ci :: ('addr, 'heap) check_instr' set"
  morphisms ci_app Abs_check_instr
by auto

lemma ci_app_check_instr' [simp]: "ci_app (Abs_check_instr check_instr') = check_instr'"
by(simp add: Abs_check_instr_inverse)

lemma (in JVM_heap_base) ci_app_check_instr [simp]: "ci_app (Abs_check_instr check_instr) = check_instr"
by(simp add: Abs_check_instr_inverse)

lemma wf_ci_stk_offerD:
  "ci_app ci ins P h stk loc C M pc frs  ci_app ci ins P h (stk @ stk') loc C M pc frs"
apply(rule ci_stk_offerD[OF wf_ciD1]) back
by(rule ci_app [simplified])

lemma wf_ciD2_ci_app:
  "ci_app ci ins P h stk loc C M pc frs  check_instr' ins P h stk loc C M pc frs"
apply(cases ci)
apply(simp add: Abs_check_instr_inverse)
apply(erule (1) wf_ciD2)
done

lemma wf_ciD3_ci_app:
  " ci_app ci ins P h stk loc C M pc frs; ins_jump_ok ins pc'   ci_app ci ins P h stk loc C M pc' frs"
apply(cases ci)
apply(simp add: Abs_check_instr_inverse)
apply(erule (2) wf_ciD3)
done

lemma wf_ciD3'_ci_app: " ci_app ci ins P h stk loc C M pc frs; pc  pc'   ci_app ci ins P h stk loc C M pc' frs"
apply(cases ci)
apply(simp add: Abs_check_instr_inverse)
apply(erule (2) wf_ciD3')
done

context JVM_heap_base begin

inductive exec_meth ::
  "('addr, 'heap) check_instr  'addr jvm_prog  'addr instr list  ex_table  'thread_id
   'heap  ('addr val list × 'addr val list × pc × 'addr option)  ('addr, 'thread_id, 'heap) jvm_thread_action
   'heap  ('addr val list × 'addr val list × pc × 'addr option)  bool"
for ci :: "('addr, 'heap) check_instr" and P :: "'addr jvm_prog" 
and ins :: "'addr instr list" and xt :: "ex_table" and t :: 'thread_id
where
  exec_instr: 
  " (ta, xcp, h', [(stk', loc', undefined, undefined, pc')])  exec_instr (ins ! pc) P t h stk loc undefined undefined pc [];
     pc < length ins;
     ci_app ci (ins ! pc) P h stk loc undefined undefined pc [] 
   exec_meth ci P ins xt t h (stk, loc, pc, None) ta h' (stk', loc', pc', xcp)"

| exec_catch:
  " match_ex_table P (cname_of h xcp) pc xt = (pc', d); d  length stk 
   exec_meth ci P ins xt t h (stk, loc, pc, xcp) ε h (Addr xcp # drop (size stk - d) stk, loc, pc', None)"

lemma exec_meth_instr:
  "exec_meth ci P ins xt t h (stk, loc, pc, None) ta h' (stk', loc', pc', xcp) 
   (ta, xcp, h', [(stk', loc', undefined, undefined, pc')])  exec_instr (ins ! pc) P t h stk loc undefined undefined pc []  pc < length ins  ci_app ci (ins ! pc) P h stk loc undefined undefined pc []"
by(auto elim: exec_meth.cases intro: exec_instr)

lemma exec_meth_xcpt:
  "exec_meth ci P ins xt t h (stk, loc, pc, xcp) ta h (stk', loc', pc', xcp') 
   (d. match_ex_table P (cname_of h xcp) pc xt = (pc', d)  ta = ε  stk' = (Addr xcp # drop (size stk - d) stk)  loc' = loc  xcp' = None  d  length stk)"
by(auto elim: exec_meth.cases intro: exec_catch)

abbreviation exec_meth_a
where "exec_meth_a  exec_meth (Abs_check_instr check_instr')"

abbreviation exec_meth_d
where "exec_meth_d  exec_meth (Abs_check_instr check_instr)"

lemma exec_meth_length_compE2D [dest]:
  "exec_meth ci P (compE2 e) (compxE2 e 0 d) t h (stk, loc, pc, xcp) ta h' s'  pc < length (compE2 e)"
apply(erule exec_meth.cases)
apply(auto dest: match_ex_table_pc_length_compE2)
done

lemma exec_meth_length_compEs2D [dest]:
  "exec_meth ci P (compEs2 es) (compxEs2 es 0 0) t h (stk, loc, pc, xcp) ta h' s'  pc < length (compEs2 es)"
apply(erule exec_meth.cases)
apply(auto dest: match_ex_table_pc_length_compEs2)
done

lemma exec_instr_stk_offer:
  assumes check: "check_instr' (ins ! pc) P h stk loc C M pc frs"
  and exec: "(ta', xcp', h', (stk', loc', C, M, pc') # frs)  exec_instr (ins ! pc) P t h stk loc C M pc frs"
  shows "(ta', xcp', h', (stk' @ stk'', loc', C, M, pc') # frs)  exec_instr (ins ! pc) P t h (stk @ stk'') loc C M pc frs"
using assms
proof(cases "ins ! pc")
  case (Invoke M n)
  thus ?thesis using exec check
    by(auto split: if_split_asm extCallRet.splits split del: if_split simp add: split_beta nth_append min_def extRet2JVM_def)
qed(force simp add: nth_append is_Ref_def has_method_def nth_Cons split_beta hd_append tl_append neq_Nil_conv split: list.split if_split_asm nat.splits sum.split_asm)+

lemma exec_meth_stk_offer:
  assumes exec: "exec_meth ci P ins xt t h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
  shows "exec_meth ci P ins (stack_xlift (length stk'') xt) t h (stk @ stk'', loc, pc, xcp) ta h' (stk' @ stk'', loc', pc', xcp')"
using exec
proof(cases)
  case (exec_catch xcp d)
  from ‹match_ex_table P (cname_of h xcp) pc xt = (pc', d)
  have "match_ex_table P (cname_of h xcp) pc (stack_xlift (length stk'') xt) = (pc', length stk'' + d)"
    by(simp add: match_ex_table_stack_xlift)
  moreover have "length stk'' + d  length (stk @ stk'')" using d  length stk by simp
  ultimately have "exec_meth ci P ins (stack_xlift (length stk'') xt) t h ((stk @ stk''), loc, pc, xcp) ε h ((Addr xcp # drop (length (stk @ stk'') - (length stk'' + d)) (stk @ stk'')), loc, pc', None)"
    by(rule exec_meth.exec_catch)
  with exec_catch show ?thesis by(simp)
next
  case exec_instr
  note ciins = ‹ci_app ci (ins ! pc) P h stk loc undefined undefined pc []
  hence "ci_app ci (ins ! pc) P h (stk @ stk'') loc undefined undefined pc []"
    by(rule wf_ci_stk_offerD)
  moreover from ciins
  have "check_instr' (ins ! pc) P h stk loc undefined undefined  pc []"
    by(rule wf_ciD2_ci_app)
  hence "(ta, xcp', h', [(stk' @ stk'', loc', undefined, undefined, pc')])  exec_instr (ins ! pc) P t h (stk @ stk'') loc undefined undefined pc []"
    using (ta, xcp', h', [(stk', loc', undefined,undefined , pc')])  exec_instr (ins ! pc) P t h stk loc undefined undefined pc []
    by(rule exec_instr_stk_offer)
  ultimately show ?thesis using exec_instr by(auto intro: exec_meth.exec_instr)
qed
  
lemma exec_meth_append_xt [intro]:
  "exec_meth ci P ins xt t h s ta h' s'
   exec_meth ci P (ins @ ins') (xt @ xt') t h s ta h' s'"
apply(erule exec_meth.cases)
 apply(auto)
 apply(rule exec_instr)
   apply(clarsimp simp add: nth_append)
  apply(simp)
 apply(simp add: nth_append)
apply(rule exec_catch)
by(simp)

lemma exec_meth_append [intro]:
  "exec_meth ci P ins xt t h s ta h' s'  exec_meth ci P (ins @ ins') xt t h s ta h' s'"
by(rule exec_meth_append_xt[where xt'="[]", simplified])

lemma append_exec_meth_xt:
  assumes exec: "exec_meth ci P ins xt t h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
  and jump: "jump_ok ins 0 n"
  and pcs: "pcs xt'  {0..<length ins'}"
  shows "exec_meth ci P (ins' @ ins) (xt' @ shift (length ins') xt) t h (stk, loc, (length ins' + pc), xcp) ta h' (stk', loc', (length ins' + pc'), xcp')"
using exec
proof(cases)
  case (exec_catch xcp d)
  from ‹match_ex_table P (cname_of h xcp) pc xt = (pc', d)
  have "match_ex_table P (cname_of h xcp) (length ins' + pc) (shift (length ins') xt) = (length ins' + pc', d)"
    by(simp add: match_ex_table_shift)
  moreover from pcs have "length ins' + pc  pcs xt'" by(auto)
  ultimately have "match_ex_table P (cname_of h xcp) (length ins' + pc) (xt' @ shift (length ins') xt) = (length ins' + pc', d)"
    by(simp add: match_ex_table_append_not_pcs)
  with exec_catch show ?thesis by(auto dest: exec_meth.exec_catch)
next
  case exec_instr
  note exec = (ta, xcp', h', [(stk', loc', undefined, undefined, pc')])  exec_instr (ins ! pc) P t h stk loc undefined undefined pc []
  hence "(ta, xcp', h', [(stk', loc', undefined, undefined, length ins' + pc')])  exec_instr (ins ! pc) P t h stk loc undefined undefined (length ins' + pc) []"
  proof(cases "ins ! pc")
    case (Goto i)
    with jump pc < length ins have "- int pc   i" "i < int (length ins - pc + n)"
      by(auto dest: jump_ok_GotoD)
    with exec Goto show ?thesis by(auto)
  next
    case (IfFalse i)
    with jump pc < length ins have "- int pc   i" "i < int (length ins - pc + n)"
      by(auto dest: jump_ok_IfFalseD)
    with exec IfFalse show ?thesis by(auto)
  next
    case (Invoke M n)
    with exec show ?thesis 
      by(auto split: if_split_asm extCallRet.splits split del: if_split simp add: split_beta nth_append min_def extRet2JVM_def)
  qed(auto simp add: split_beta split: if_split_asm sum.split_asm)
  moreover from ‹ci_app ci (ins ! pc) P h stk loc undefined undefined pc []
  have "ci_app ci (ins ! pc) P h stk loc undefined undefined (length ins' + pc) []"
    by(rule wf_ciD3'_ci_app) simp
  ultimately have "exec_meth ci P (ins' @ ins) (xt' @ shift (length ins') xt) t h (stk, loc, (length ins' + pc), None) ta h' (stk', loc', (length ins' + pc'), xcp')"
    using pc < length ins by -(rule exec_meth.exec_instr, simp_all)
  thus ?thesis using exec_instr by(auto)
qed

lemma append_exec_meth:
  assumes exec: "exec_meth ci P ins xt t h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
  and jump: "jump_ok ins 0 n"
  shows "exec_meth ci P (ins' @ ins) (shift (length ins') xt) t h (stk, loc, (length ins' + pc), xcp) ta h' (stk', loc', (length ins' + pc'), xcp')"
using assms by(rule append_exec_meth_xt [where xt'="[]", simplified])

lemma exec_meth_take_xt':
  " exec_meth ci P (ins @ ins') (xt' @ xt) t h (stk, loc, pc, xcp) ta h' s';
    pc < length ins; pc  pcs xt 
   exec_meth ci P ins xt' t h (stk, loc, pc, xcp) ta h' s'"
apply(erule exec_meth.cases)
apply(auto intro: exec_meth.intros simp add: match_ex_table_append nth_append dest: match_ex_table_pcsD)
done

lemma exec_meth_take_xt:
  " exec_meth ci P (ins @ ins') (xt' @ shift (length ins) xt) t h (stk, loc, pc, xcp) ta h' s';
    pc < length ins 
   exec_meth ci P ins xt' t h (stk, loc, pc, xcp) ta h' s'"
by(auto intro: exec_meth_take_xt')

lemma exec_meth_take:
  " exec_meth ci P (ins @ ins') xt t h (stk, loc, pc, xcp) ta h' s';
    pc < length ins 
   exec_meth ci P ins xt t h (stk, loc, pc, xcp) ta h' s'"
by(auto intro: exec_meth_take_xt[where xt = "[]"])


lemma exec_meth_drop_xt:
  assumes exec: "exec_meth ci P (ins @ ins') (xt @ shift (length ins) xt') t h (stk, loc, (length ins + pc), xcp) ta h' (stk', loc', pc', xcp')"
  and xt: "pcs xt  {..<length ins}"
  and jump: "jump_ok ins' 0 n"
  shows "exec_meth ci P ins' xt' t h (stk, loc, pc, xcp) ta h' (stk', loc', (pc' - length ins), xcp')"
using exec
proof(cases rule: exec_meth.cases)
  case exec_instr
  let ?PC = "length ins + pc"
  note [simp] = xcp = None›
  from ?PC < length (ins @ ins') have pc: "pc < length ins'" by simp
  moreover with (ta, xcp', h', [(stk', loc', undefined, undefined, pc')])  exec_instr ((ins @ ins') ! ?PC) P t h stk loc undefined undefined ?PC []
  have "(ta, xcp', h', [(stk', loc', undefined, undefined, pc' - length ins)])  exec_instr (ins' ! pc) P t h stk loc undefined undefined pc []"
    apply(cases "ins' ! pc")
    apply(simp_all add: split_beta split: if_split_asm sum.split_asm split del: if_split)
    apply(force split: extCallRet.splits simp add: min_def extRet2JVM_def)+
    done
  moreover from ‹ci_app ci ((ins @ ins') ! ?PC) P h stk loc undefined undefined ?PC [] jump pc
  have "ci_app ci (ins' ! pc) P h stk loc undefined undefined pc []"
    by(fastforce elim: wf_ciD3_ci_app dest: jump_ok_ins_jump_ok)
  ultimately show ?thesis by(auto intro: exec_meth.intros)
next
  case (exec_catch XCP D)
  let ?PC = "length ins + pc"
  note [simp] = xcp = XCP
    ta = ε h' = h stk' = Addr XCP # drop (length stk - D) stk loc' = loc xcp' = None›
  from ‹match_ex_table P (cname_of h XCP) ?PC (xt @ shift (length ins) xt') = (pc', D) xt
  have "match_ex_table P (cname_of h XCP) pc xt' = (pc' - length ins, D)"
    by(auto simp add: match_ex_table_append dest: match_ex_table_shift_pcD match_ex_table_pcsD)
  with D  length stk show ?thesis by(auto intro: exec_meth.intros)
qed

lemma exec_meth_drop:
  " exec_meth ci P (ins @ ins') (shift (length ins) xt) t h (stk, loc, (length ins + pc), xcp) ta h' (stk', loc', pc', xcp');
     jump_ok ins' 0 b 
    exec_meth ci P ins' xt t h (stk, loc, pc, xcp) ta h' (stk', loc', (pc' - length ins), xcp')"
by(auto intro: exec_meth_drop_xt[where xt = "[]"])

lemma exec_meth_drop_xt_pc:
  assumes exec: "exec_meth ci P (ins @ ins') (xt @ shift (length ins) xt') t h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
  and pc: "pc  length ins"
  and pcs: "pcs xt  {..<length ins}"
  and jump: "jump_ok ins' 0 n'"
  shows "pc'  length ins"
using exec
proof(cases rule: exec_meth.cases)
  case exec_instr thus ?thesis using jump pc
    apply(cases "ins' ! (pc - length ins)")
    apply(simp_all add: split_beta nth_append split: if_split_asm sum.split_asm)
    apply(force split: extCallRet.splits simp add: min_def extRet2JVM_def dest: jump_ok_GotoD jump_ok_IfFalseD)+
    done
next
  case exec_catch thus ?thesis using pcs pc
    by(auto dest: match_ex_table_pcsD match_ex_table_shift_pcD simp add: match_ex_table_append)
qed

lemmas exec_meth_drop_pc = exec_meth_drop_xt_pc[where xt="[]", simplified]

definition exec_move ::
  "('addr, 'heap) check_instr  'addr J1_prog  'thread_id  'addr expr1
   'heap   ('addr val list × 'addr val list × pc × 'addr option)
   ('addr, 'thread_id, 'heap) jvm_thread_action
   'heap  ('addr val list × 'addr val list × pc × 'addr option)  bool"
where "exec_move ci P t e  exec_meth ci (compP2 P) (compE2 e) (compxE2 e 0 0) t"

definition exec_moves :: 
  "('addr, 'heap) check_instr  'addr J1_prog  'thread_id  'addr expr1 list
   'heap  ('addr val list × 'addr val list × pc × 'addr option)
   ('addr, 'thread_id, 'heap) jvm_thread_action
   'heap  ('addr val list × 'addr val list × pc × 'addr option)  bool"
where "exec_moves ci P t es  exec_meth ci (compP2 P) (compEs2 es) (compxEs2 es 0 0) t"

abbreviation exec_move_a
where "exec_move_a  exec_move (Abs_check_instr check_instr')"

abbreviation exec_move_d
where "exec_move_d  exec_move (Abs_check_instr check_instr)"

abbreviation exec_moves_a
where "exec_moves_a  exec_moves (Abs_check_instr check_instr')"

abbreviation exec_moves_d
where "exec_moves_d  exec_moves (Abs_check_instr check_instr)"

lemma exec_move_newArrayI:
  "exec_move ci P t e h s ta h' s'  exec_move ci P t (newA Te) h s ta h' s'"
unfolding exec_move_def by auto

lemma exec_move_newArray:
  "pc < length (compE2 e)  exec_move ci P t (newA Te) h (stk, loc, pc, xcp) = exec_move ci P t e h (stk, loc, pc, xcp)"
unfolding exec_move_def by(auto intro!: ext intro: exec_meth_take)

lemma exec_move_CastI:
  "exec_move ci P t e h s ta h' s'  exec_move ci P t (Cast T e) h s ta h' s'"
unfolding exec_move_def by auto

lemma exec_move_Cast:
  "pc < length (compE2 e)  exec_move ci P t (Cast T e) h (stk, loc, pc, xcp) = exec_move ci P t e h (stk, loc, pc, xcp)"
unfolding exec_move_def by(auto intro!: ext intro: exec_meth_take)

lemma exec_move_InstanceOfI:
  "exec_move ci P t e h s ta h' s'  exec_move ci P t (e instanceof T) h s ta h' s'"
unfolding exec_move_def by auto

lemma exec_move_InstanceOf:
  "pc < length (compE2 e)  exec_move ci P t (e instanceof T) h (stk, loc, pc, xcp) = exec_move ci P t e h (stk, loc, pc, xcp)"
unfolding exec_move_def by(auto intro!: ext intro: exec_meth_take)

lemma exec_move_BinOpI1:
  "exec_move ci P t e h s ta h' s'  exec_move ci P t (e «bop» e') h s ta h' s'"
unfolding exec_move_def by auto

lemma exec_move_BinOp1:
  "pc < length (compE2 e)  exec_move ci P t (e «bop» e') h (stk, loc, pc, xcp) = exec_move ci P t e h (stk, loc, pc, xcp)"
unfolding exec_move_def
by(auto intro!: ext intro: exec_meth_take_xt simp add: compxE2_size_convs)

lemma exec_move_BinOpI2:
  assumes exec: "exec_move ci P t e2 h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
  shows "exec_move ci P t (e1 «bop» e2) h (stk @ [v], loc, length (compE2 e1) + pc, xcp) ta h' (stk' @ [v], loc', length (compE2 e1) + pc', xcp')"
proof -
  from exec have "exec_meth ci (compP2 P) (compE2 e2) (compxE2 e2 0 0) t h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
    unfolding exec_move_def .
  from exec_meth_stk_offer[OF this, where stk''="[v]"] show ?thesis
    by(fastforce split: bop.splits intro: append_exec_meth_xt simp add: exec_move_def compxE2_size_convs compxE2_stack_xlift_convs)
qed

lemma exec_move_LAssI:
  "exec_move ci P t e h s ta h' s'  exec_move ci P t (V := e) h s ta h' s'"
unfolding exec_move_def by auto

lemma exec_move_LAss:
  "pc < length (compE2 e)  exec_move ci P t (V := e) h (stk, loc, pc, xcp) = exec_move ci P t e h (stk, loc, pc, xcp)"
unfolding exec_move_def by(auto intro!: ext intro: exec_meth_take)

lemma exec_move_AAccI1:
  "exec_move ci P t e h s ta h' s'  exec_move ci P t (ee') h s ta h' s'"
unfolding exec_move_def by auto

lemma exec_move_AAcc1:
  "pc < length (compE2 e)  exec_move ci P t (ee') h (stk, loc, pc, xcp) = exec_move ci P t e h (stk, loc, pc, xcp)"
unfolding exec_move_def
by(auto intro!: ext intro: exec_meth_take_xt simp add: compxE2_size_convs)

lemma exec_move_AAccI2:
  assumes exec: "exec_move ci P t e2 h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
  shows "exec_move ci P t (e1e2) h (stk @ [v], loc, length (compE2 e1) + pc, xcp) ta h' (stk' @ [v], loc', length (compE2 e1) + pc', xcp')"
proof -
  from exec have "exec_meth ci (compP2 P) (compE2 e2) (compxE2 e2 0 0) t h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
    unfolding exec_move_def .
  from exec_meth_stk_offer[OF this, where stk''="[v]"] show ?thesis
    by(fastforce intro: append_exec_meth_xt simp add: exec_move_def compxE2_size_convs compxE2_stack_xlift_convs)
qed

lemma exec_move_AAssI1:
  "exec_move ci P t e h s ta h' s'  exec_move ci P t (ee' := e'') h s ta h' s'"
unfolding exec_move_def by auto

lemma exec_move_AAss1:
  assumes pc: "pc < length (compE2 e)"
  shows "exec_move ci P t (ee' := e'') h (stk, loc, pc, xcp) = exec_move ci P t e h (stk, loc, pc, xcp)"
  (is "?lhs = ?rhs")
proof(rule ext iffI)+
  fix ta h' s' assume "?rhs ta h' s'"
  thus "?lhs ta h' s'" by(rule exec_move_AAssI1)
next
  fix ta h' s' assume "?lhs ta h' s'"
  hence "exec_meth ci (compP2 P) (compE2 e @ compE2 e' @ compE2 e'' @ [AStore, Push Unit])
     (compxE2 e 0 0 @ shift (length (compE2 e)) (compxE2 e' 0 (Suc 0) @ compxE2 e'' (length (compE2 e')) (Suc (Suc 0)))) t
     h (stk, loc, pc, xcp) ta h' s'" by(simp add: exec_move_def shift_compxE2 ac_simps)
  thus "?rhs ta h' s'" unfolding exec_move_def using pc by(rule exec_meth_take_xt)
qed

lemma exec_move_AAssI2:
  assumes exec: "exec_move ci P t e2 h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
  shows "exec_move ci P t (e1e2 := e3) h (stk @ [v], loc, length (compE2 e1) + pc, xcp) ta h' (stk' @ [v], loc', length (compE2 e1) + pc', xcp')"
proof -
  from exec have "exec_meth ci (compP2 P) (compE2 e2) (compxE2 e2 0 0) t h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
    unfolding exec_move_def .
  from exec_meth_stk_offer[OF this, where stk''="[v]", simplified stack_xlift_compxE2, simplified]
  have "exec_meth ci (compP2 P) (compE2 e2 @ compE2 e3 @ [AStore, Push Unit]) (compxE2 e2 0 (Suc 0) @ shift (length (compE2 e2)) (compxE2 e3 0 (Suc (Suc 0)))) t h (stk @ [v], loc, pc, xcp) ta h' (stk' @ [v], loc', pc', xcp')"
    by(rule exec_meth_append_xt)
  hence "exec_meth ci (compP2 P) (compE2 e1 @ compE2 e2 @ compE2 e3 @ [AStore, Push Unit]) (compxE2 e1 0 0 @ shift (length (compE2 e1)) (compxE2 e2 0 (Suc 0) @ shift (length (compE2 e2)) (compxE2 e3 0 (Suc (Suc 0))))) t h (stk @ [v], loc, length (compE2 e1) + pc, xcp) ta h' (stk' @ [v], loc', length (compE2 e1) + pc', xcp')"
    by(rule append_exec_meth_xt) auto
  thus ?thesis by(auto simp add: exec_move_def shift_compxE2 ac_simps)
qed

lemma exec_move_AAssI3:
  assumes exec: "exec_move ci P t e3 h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
  shows "exec_move ci P t (e1e2 := e3) h (stk @ [v', v], loc, length (compE2 e1) + length (compE2 e2) + pc, xcp) ta h' (stk' @ [v', v], loc', length (compE2 e1) + length (compE2 e2) + pc', xcp')"
proof -
  from exec have "exec_meth ci (compP2 P) (compE2 e3) (compxE2 e3 0 0) t h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
    unfolding exec_move_def .
  from exec_meth_stk_offer[OF this, where stk''="[v', v]", simplified stack_xlift_compxE2, simplified]
  have "exec_meth ci (compP2 P) (compE2 e3 @ [AStore, Push Unit]) (compxE2 e3 0 (Suc (Suc 0))) t h (stk @ [v', v], loc, pc, xcp) ta h' (stk' @ [v', v], loc', pc', xcp')"
    by(rule exec_meth_append)
  hence "exec_meth ci (compP2 P) ((compE2 e1 @ compE2 e2) @ compE2 e3 @ [AStore, Push Unit]) 
                   ((compxE2 e1 0 0 @ compxE2 e2 (length (compE2 e1)) (Suc 0)) @ shift (length (compE2 e1 @ compE2 e2)) (compxE2 e3 0 (Suc (Suc 0)))) t h (stk @ [v', v], loc, length (compE2 e1 @ compE2 e2) + pc, xcp) ta h' (stk' @ [v', v], loc', length (compE2 e1 @ compE2 e2) + pc', xcp')"
    by(rule append_exec_meth_xt) auto
  thus ?thesis by(auto simp add: exec_move_def shift_compxE2 ac_simps)
qed

lemma exec_move_ALengthI:
  "exec_move ci P t e h s ta h' s'  exec_move ci P t (e∙length) h s ta h' s'"
unfolding exec_move_def by auto

lemma exec_move_ALength:
  "pc < length (compE2 e)  exec_move ci P t (e∙length) h (stk, loc, pc, xcp) = exec_move ci P t e h (stk, loc, pc, xcp)"
unfolding exec_move_def by(auto intro!: ext intro: exec_meth_take)

lemma exec_move_FAccI:
  "exec_move ci P t e h s ta h' s'  exec_move ci P t (eF{D}) h s ta h' s'"
unfolding exec_move_def by auto

lemma exec_move_FAcc:
  "pc < length (compE2 e)  exec_move ci P t (eF{D}) h (stk, loc, pc, xcp) = exec_move ci P t e h (stk, loc, pc, xcp)"
unfolding exec_move_def by(auto intro!: ext intro: exec_meth_take)

lemma exec_move_FAssI1:
  "exec_move ci P t e h s ta h' s'  exec_move ci P t (eF{D} := e') h s ta h' s'"
unfolding exec_move_def by auto

lemma exec_move_FAss1:
  "pc < length (compE2 e)  exec_move ci P t (eF{D} := e') h (stk, loc, pc, xcp) = exec_move ci P t e h (stk, loc, pc, xcp)"
unfolding exec_move_def
by(auto intro!: ext intro: exec_meth_take_xt simp add: compxE2_size_convs)

lemma exec_move_FAssI2:
  assumes exec: "exec_move ci P t e2 h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
  shows "exec_move ci P t (e1F{D} := e2) h (stk @ [v], loc, length (compE2 e1) + pc, xcp) ta h' (stk' @ [v], loc', length (compE2 e1) + pc', xcp')"
proof -
  from exec have "exec_meth ci (compP2 P) (compE2 e2) (compxE2 e2 0 0) t h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
    unfolding exec_move_def .
  from exec_meth_stk_offer[OF this, where stk''="[v]"] show ?thesis
    by(fastforce intro: append_exec_meth_xt simp add: exec_move_def compxE2_size_convs compxE2_stack_xlift_convs)
qed

lemma exec_move_CASI1:
  "exec_move ci P t e h s ta h' s'  exec_move ci P t (e∙compareAndSwap(DF, e', e'')) h s ta h' s'"
unfolding exec_move_def by auto

lemma exec_move_CAS1:
  assumes pc: "pc < length (compE2 e)"
  shows "exec_move ci P t (e∙compareAndSwap(DF, e', e'')) h (stk, loc, pc, xcp) = exec_move ci P t e h (stk, loc, pc, xcp)"
  (is "?lhs = ?rhs")
proof(rule ext iffI)+
  fix ta h' s' assume "?rhs ta h' s'"
  thus "?lhs ta h' s'" by(rule exec_move_CASI1)
next
  fix ta h' s' assume "?lhs ta h' s'"
  hence "exec_meth ci (compP2 P) (compE2 e @ compE2 e' @ compE2 e'' @ [CAS F D])
     (compxE2 e 0 0 @ shift (length (compE2 e)) (compxE2 e' 0 (Suc 0) @ compxE2 e'' (length (compE2 e')) (Suc (Suc 0)))) t
     h (stk, loc, pc, xcp) ta h' s'" by(simp add: exec_move_def shift_compxE2 ac_simps)
  thus "?rhs ta h' s'" unfolding exec_move_def using pc by(rule exec_meth_take_xt)
qed

lemma exec_move_CASI2:
  assumes exec: "exec_move ci P t e2 h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
  shows "exec_move ci P t (e1∙compareAndSwap(DF, e2, e3)) h (stk @ [v], loc, length (compE2 e1) + pc, xcp) ta h' (stk' @ [v], loc', length (compE2 e1) + pc', xcp')"
proof -
  from exec have "exec_meth ci (compP2 P) (compE2 e2) (compxE2 e2 0 0) t h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
    unfolding exec_move_def .
  from exec_meth_stk_offer[OF this, where stk''="[v]", simplified stack_xlift_compxE2, simplified]
  have "exec_meth ci (compP2 P) (compE2 e2 @ compE2 e3 @ [CAS F D]) (compxE2 e2 0 (Suc 0) @ shift (length (compE2 e2)) (compxE2 e3 0 (Suc (Suc 0)))) t h (stk @ [v], loc, pc, xcp) ta h' (stk' @ [v], loc', pc', xcp')"
    by(rule exec_meth_append_xt)
  hence "exec_meth ci (compP2 P) (compE2 e1 @ compE2 e2 @ compE2 e3 @ [CAS F D]) (compxE2 e1 0 0 @ shift (length (compE2 e1)) (compxE2 e2 0 (Suc 0) @ shift (length (compE2 e2)) (compxE2 e3 0 (Suc (Suc 0))))) t h (stk @ [v], loc, length (compE2 e1) + pc, xcp) ta h' (stk' @ [v], loc', length (compE2 e1) + pc', xcp')"
    by(rule append_exec_meth_xt) auto
  thus ?thesis by(auto simp add: exec_move_def shift_compxE2 ac_simps)
qed

lemma exec_move_CASI3:
  assumes exec: "exec_move ci P t e3 h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
  shows "exec_move ci P t (e1∙compareAndSwap(DF, e2, e3)) h (stk @ [v', v], loc, length (compE2 e1) + length (compE2 e2) + pc, xcp) ta h' (stk' @ [v', v], loc', length (compE2 e1) + length (compE2 e2) + pc', xcp')"
proof -
  from exec have "exec_meth ci (compP2 P) (compE2 e3) (compxE2 e3 0 0) t h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
    unfolding exec_move_def .
  from exec_meth_stk_offer[OF this, where stk''="[v', v]", simplified stack_xlift_compxE2, simplified]
  have "exec_meth ci (compP2 P) (compE2 e3 @ [CAS F D]) (compxE2 e3 0 (Suc (Suc 0))) t h (stk @ [v', v], loc, pc, xcp) ta h' (stk' @ [v', v], loc', pc', xcp')"
    by(rule exec_meth_append)
  hence "exec_meth ci (compP2 P) ((compE2 e1 @ compE2 e2) @ compE2 e3 @ [CAS F D]) 
                   ((compxE2 e1 0 0 @ compxE2 e2 (length (compE2 e1)) (Suc 0)) @ shift (length (compE2 e1 @ compE2 e2)) (compxE2 e3 0 (Suc (Suc 0)))) t h (stk @ [v', v], loc, length (compE2 e1 @ compE2 e2) + pc, xcp) ta h' (stk' @ [v', v], loc', length (compE2 e1 @ compE2 e2) + pc', xcp')"
    by(rule append_exec_meth_xt) auto
  thus ?thesis by(auto simp add: exec_move_def shift_compxE2 ac_simps)
qed

lemma exec_move_CallI1:
  "exec_move ci P t e h s ta h' s'  exec_move ci P t (eM(es)) h s ta h' s'"
unfolding exec_move_def by auto

lemma exec_move_Call1:
  "pc < length (compE2 e)  exec_move ci P t (eM(es)) h (stk, loc, pc, xcp) = exec_move ci P t e h (stk, loc, pc, xcp)"
unfolding exec_move_def
by(auto intro!: ext intro: exec_meth_take_xt simp add: compxEs2_size_convs)

lemma exec_move_CallI2:
  assumes exec: "exec_moves ci P t es h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
  shows "exec_move ci P t (eM(es)) h (stk @ [v], loc, length (compE2 e) + pc, xcp) ta h' (stk' @ [v], loc', length (compE2 e) + pc', xcp')"
proof -
  from exec have "exec_meth ci (compP2 P) (compEs2 es) (compxEs2 es 0 0) t h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
    unfolding exec_moves_def .
  from exec_meth_stk_offer[OF this, where stk''="[v]"] show ?thesis
    by(fastforce intro: append_exec_meth_xt simp add: exec_move_def compxEs2_size_convs compxEs2_stack_xlift_convs)
qed

lemma exec_move_BlockNoneI:
  "exec_move ci P t e h s ta h' s'  exec_move ci P t {V:T=None; e} h s ta h' s'"
unfolding exec_move_def by simp

lemma exec_move_BlockNone:
  "exec_move ci P t {V:T=None; e} = exec_move ci P t e"
unfolding exec_move_def by(simp)

lemma exec_move_BlockSomeI:
  assumes exec: "exec_move ci P t e h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
  shows "exec_move ci P t {V:T=v; e} h (stk, loc, Suc (Suc pc), xcp) ta h' (stk', loc', Suc (Suc pc'), xcp')"
proof -
  let ?ins = "[Push v, Store V]"
  from exec have "exec_meth ci (compP2 P) (compE2 e) (compxE2 e 0 0) t h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
    by(simp add: exec_move_def)
  hence "exec_meth ci (compP2 P) (?ins @ compE2 e) (shift (length ?ins) (compxE2 e 0 0)) t h (stk, loc, length ?ins + pc, xcp) ta h' (stk', loc', length ?ins + pc', xcp')"
    by(rule append_exec_meth) auto
  thus ?thesis by(simp add: exec_move_def shift_compxE2)
qed

lemma exec_move_BlockSome:
  "exec_move ci P t {V:T=v; e} h (stk, loc, Suc (Suc pc), xcp) ta h' (stk', loc', Suc (Suc pc'), xcp') =
   exec_move ci P t e h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')" (is "?lhs = ?rhs")
proof
  assume ?rhs thus ?lhs by(rule exec_move_BlockSomeI)
next
  let ?ins = "[Push v, Store V]"
  assume ?lhs
  hence "exec_meth ci (compP2 P) (?ins @ compE2 e) (shift (length ?ins) (compxE2 e 0 0)) t h (stk, loc, length ?ins + pc, xcp) ta h' (stk', loc', length ?ins + pc', xcp')"
    by(simp add: exec_move_def shift_compxE2)
  hence "exec_meth ci (compP2 P) (compE2 e) (compxE2 e 0 0) t h (stk, loc, pc, xcp) ta h' (stk', loc', length ?ins + pc' - length ?ins, xcp')"
    by(rule exec_meth_drop) auto
  thus ?rhs by(simp add: exec_move_def)
qed

lemma exec_move_SyncI1:
  "exec_move ci P t e h s ta h' s'  exec_move ci P t (syncV (e) e') h s ta h' s'"
unfolding exec_move_def by auto

lemma exec_move_Sync1:
  assumes pc: "pc < length (compE2 e)"
  shows "exec_move ci P t (syncV (e) e') h (stk, loc, pc, xcp) = exec_move ci P t e h (stk, loc, pc, xcp)"
  (is "?lhs = ?rhs")
proof(rule ext iffI)+
  fix ta h' s'
  assume "?lhs ta h' s'"
  hence "exec_meth ci (compP2 P) (compE2 e @ Dup # Store V # MEnter # compE2 e' @ [Load V, MExit, Goto 4, Load V, MExit, ThrowExc])
                   (compxE2 e 0 0 @ shift (length (compE2 e)) (compxE2 e' 3 0 @ [(3, 3 + length (compE2 e'), None, 6 + length (compE2 e'), 0)]))
                   t h (stk, loc, pc, xcp) ta h' s'"
    by(simp add: shift_compxE2 ac_simps exec_move_def)
  thus "?rhs ta h' s'" unfolding exec_move_def using pc by(rule exec_meth_take_xt)
qed(rule exec_move_SyncI1)

lemma exec_move_SyncI2:
  assumes exec: "exec_move ci P t e h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
  shows "exec_move ci P t (syncV (o') e) h (stk, loc, (Suc (Suc (Suc (length (compE2 o') + pc)))), xcp) ta h' (stk', loc', (Suc (Suc (Suc (length (compE2 o') + pc')))), xcp')"
proof -
  let ?e = "compE2 o' @ [Dup, Store V, MEnter]"
  let ?e' = "[Load V, MExit, Goto 4, Load V, MExit, ThrowExc]"
  from exec have "exec_meth ci (compP2 P) (compE2 e) (compxE2 e 0 0) t h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
    by(simp add: exec_move_def)
  hence "exec_meth ci (compP2 P) ((?e @ compE2 e) @ ?e') ((compxE2 o' 0 0 @ shift (length ?e) (compxE2 e 0 0)) @ [(length ?e, length ?e + length (compE2 e), None, length ?e + length (compE2 e) + 3, 0)]) t h (stk, loc, (length ?e + pc), xcp) ta h' (stk', loc', (length ?e + pc'), xcp')"
    by(rule exec_meth_append_xt[OF append_exec_meth_xt]) auto
  thus ?thesis by(simp add: eval_nat_numeral shift_compxE2 exec_move_def)
qed

lemma exec_move_SeqI1:
  "exec_move ci P t e h s ta h' s'  exec_move ci P t (e;;e') h s ta h' s'"
unfolding exec_move_def by auto

lemma exec_move_Seq1:
  assumes pc: "pc < length (compE2 e)"
  shows "exec_move ci P t (e;;e') h (stk, loc, pc, xcp) = exec_move ci P t e h (stk, loc, pc, xcp)"
  (is "?lhs = ?rhs")
proof(rule ext iffI)+
  fix ta h' s'
  assume "?lhs ta h' s'"
  hence "exec_meth ci (compP2 P) (compE2 e @ Pop # compE2 e') (compxE2 e 0 0 @ shift (length (compE2 e)) (compxE2 e' (Suc 0) 0)) t h (stk, loc, pc, xcp) ta h' s'"
    by(simp add: exec_move_def shift_compxE2)
  thus "?rhs ta h' s'" unfolding exec_move_def using pc by(rule exec_meth_take_xt)
qed(rule exec_move_SeqI1)

lemma exec_move_SeqI2:
  assumes exec: "exec_move ci P t e h (stk, loc, pc, xcp) ta h' (stk', loc', pc' ,xcp')"
  shows "exec_move ci P t (e';;e) h (stk, loc, (Suc (length (compE2 e') + pc)), xcp) ta h' (stk', loc', (Suc (length (compE2 e') + pc')), xcp')"
proof -
  from exec have "exec_meth ci (compP2 P) (compE2 e) (compxE2 e 0 0) t h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
    by(simp add: exec_move_def)
  hence "exec_meth ci (compP2 P) ((compE2 e' @ [Pop]) @ compE2 e) (compxE2 e' 0 0 @ shift (length (compE2 e' @ [Pop])) (compxE2 e 0 0)) t h (stk, loc, (length ((compE2 e') @ [Pop]) + pc), xcp) ta h' (stk', loc', (length ((compE2 e') @ [Pop]) + pc'), xcp')"
    by(rule append_exec_meth_xt) auto
  thus ?thesis by(simp add: shift_compxE2 exec_move_def)
qed

lemma exec_move_Seq2:
  assumes pc: "pc < length (compE2 e)"
  shows "exec_move ci P t (e';;e) h (stk, loc, Suc (length (compE2 e') + pc), xcp) ta
                                h' (stk', loc', Suc (length (compE2 e') + pc'), xcp') =
         exec_move ci P t e h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
  (is "?lhs = ?rhs")
proof
  let ?E = "compE2 e' @ [Pop]"
  assume ?lhs
  hence "exec_meth ci (compP2 P) (?E @ compE2 e) (compxE2 e' 0 0 @ shift (length ?E) (compxE2 e 0 0)) t h (stk, loc, length ?E + pc, xcp) ta h' (stk', loc', length ?E + pc', xcp')"
    by(simp add: exec_move_def shift_compxE2)
  from exec_meth_drop_xt[OF this] show ?rhs unfolding exec_move_def by fastforce
qed(rule exec_move_SeqI2)

lemma exec_move_CondI1:
  "exec_move ci P t e h s ta h' s'  exec_move ci P t (if (e) e1 else e2) h s ta h' s'"
unfolding exec_move_def by auto

lemma exec_move_Cond1:
  assumes pc: "pc < length (compE2 e)"
  shows "exec_move ci P t (if (e) e1 else e2) h (stk, loc, pc, xcp) = exec_move ci P t e h (stk, loc, pc, xcp)"
  (is "?lhs = ?rhs")
proof(rule ext iffI)+
  let ?E = "IfFalse (2 + int (length (compE2 e1))) # compE2 e1 @ Goto (1 + int (length (compE2 e2))) # compE2 e2"
  let ?xt = "compxE2 e1 (Suc 0) 0 @ compxE2 e2 (Suc (Suc (length (compE2 e1)))) 0"
  fix ta h' s'
  assume "?lhs ta h' s'"
  hence "exec_meth ci (compP2 P) (compE2 e @ ?E) (compxE2 e 0 0 @ shift (length (compE2 e)) ?xt) t h (stk, loc, pc, xcp) ta h' s'"
    by(simp add: exec_move_def shift_compxE2 ac_simps)
  thus "?rhs ta h' s'" unfolding exec_move_def using pc by(rule exec_meth_take_xt)
qed(rule exec_move_CondI1)

lemma exec_move_CondI2:
  assumes exec: "exec_move ci P t e1 h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
  shows "exec_move ci P t (if (e) e1 else e2) h (stk, loc, (Suc (length (compE2 e) + pc)), xcp) ta h' (stk', loc', (Suc (length (compE2 e) + pc')), xcp')"
proof -
  from exec have "exec_meth ci (compP2 P) (compE2 e1) (compxE2 e1 0 0) t h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
    by(simp add: exec_move_def)
  hence "exec_meth ci (compP2 P) (((compE2 e @ [IfFalse (2 + int (length (compE2 e1)))]) @ compE2 e1) @ Goto (1 + int (length (compE2 e2))) # compE2 e2) ((compxE2 e 0 0 @ shift (length (compE2 e @ [IfFalse (2 + int (length (compE2 e1)))])) (compxE2 e1 0 0)) @ (compxE2 e2 (Suc (Suc (length (compE2 e) + length (compE2 e1)))) 0)) t h (stk, loc, (length (compE2 e @ [IfFalse (2 + int (length (compE2 e1)))]) + pc), xcp) ta h' (stk', loc', (length (compE2 e @ [IfFalse (2 + int (length (compE2 e1)))]) + pc'), xcp')"
    by -(rule exec_meth_append_xt, rule append_exec_meth_xt, auto)
  thus ?thesis by(simp add: shift_compxE2 exec_move_def)
qed

lemma exec_move_Cond2:
  assumes pc: "pc < length (compE2 e1)"
  shows "exec_move ci P t (if (e) e1 else e2) h (stk, loc, (Suc (length (compE2 e) + pc)), xcp) ta h' (stk', loc', (Suc (length (compE2 e) + pc')), xcp') = exec_move ci P t e1 h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
  (is "?lhs = ?rhs")
proof
  let ?E1 = "compE2 e @ [IfFalse (2 + int (length (compE2 e1)))]"
  let ?E2 = "Goto (1 + int (length (compE2 e2))) # compE2 e2"
  assume ?lhs
  hence "exec_meth ci (compP2 P) (?E1 @ compE2 e1 @ ?E2) (compxE2 e 0 0 @ shift (length ?E1) (compxE2 e1 0 0 @ shift (length (compE2 e1)) (compxE2 e2 (Suc 0) 0))) t h (stk, loc, length ?E1 + pc, xcp) ta h' (stk', loc', length ?E1 + pc', xcp')"
    by(simp add: exec_move_def shift_compxE2 ac_simps)
  thus ?rhs unfolding exec_move_def
    by -(rule exec_meth_take_xt,drule exec_meth_drop_xt,auto simp add: pc)
qed(rule exec_move_CondI2)

lemma exec_move_CondI3:
  assumes exec: "exec_move ci P t e2 h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
  shows "exec_move ci P t (if (e) e1 else e2) h (stk, loc, Suc (Suc (length (compE2 e) + length (compE2 e1) + pc)), xcp) ta h' (stk', loc', Suc (Suc (length (compE2 e) + length (compE2 e1) + pc')), xcp')"
proof -
  let ?E = "compE2 e @ IfFalse (2 + int (length (compE2 e1))) # compE2 e1 @ [Goto (1 + int (length (compE2 e2)))]"
  let ?xt = "compxE2 e 0 0 @ compxE2 e1 (Suc (length (compE2 e))) 0"
  from exec have "exec_meth ci (compP2 P) (compE2 e2) (compxE2 e2 0 0) t h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
    by(simp add: exec_move_def)
  hence "exec_meth ci (compP2 P) (?E @ compE2 e2) (?xt @ shift (length ?E) (compxE2 e2 0 0)) t h (stk, loc, length ?E + pc, xcp) ta h' (stk', loc', length ?E + pc', xcp')"
    by(rule append_exec_meth_xt) auto
  thus ?thesis by(simp add: shift_compxE2 exec_move_def)
qed

lemma exec_move_Cond3:
  "exec_move ci P t (if (e) e1 else e2) h (stk, loc, Suc (Suc (length (compE2 e) + length (compE2 e1) + pc)), xcp) ta
                                      h' (stk', loc', Suc (Suc (length (compE2 e) + length (compE2 e1) + pc')), xcp') =
   exec_move ci P t e2 h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
  (is "?lhs = ?rhs")
proof
  let ?E = "compE2 e @ IfFalse (2 + int (length (compE2 e1))) # compE2 e1 @ [Goto (1 + int (length (compE2 e2)))]"
  let ?xt = "compxE2 e 0 0 @ compxE2 e1 (Suc (length (compE2 e))) 0"
  assume ?lhs
  hence "exec_meth ci (compP2 P) (?E @ compE2 e2) (?xt @ shift (length ?E) (compxE2 e2 0 0)) t h (stk, loc, length ?E + pc, xcp) ta h' (stk', loc', length ?E + pc', xcp')"
    by(simp add: shift_compxE2 exec_move_def)
  thus ?rhs unfolding exec_move_def by -(drule exec_meth_drop_xt, auto)
qed(rule exec_move_CondI3)

lemma exec_move_WhileI1:
  "exec_move ci P t e h s ta h' s'  exec_move ci P t (while (e) e') h s ta h' s'"
unfolding exec_move_def by auto

lemma (in ab_group_add) uminus_minus_left_commute:
  "- a - (b + c) = - b - (a + c)"
  by (simp add: algebra_simps)

lemma exec_move_While1:
  assumes pc: "pc < length (compE2 e)"
  shows "exec_move ci P t (while (e) e') h (stk, loc, pc, xcp) = exec_move ci P t e h (stk, loc, pc, xcp)"
  (is "?lhs = ?rhs")
proof(rule ext iffI)+
  let ?E = "IfFalse (3 + int (length (compE2 e'))) # compE2 e' @ [Pop, Goto (- int (length (compE2 e)) + (-2 - int (length (compE2 e')))), Push Unit]"
  let ?xt = "compxE2 e' (Suc 0) 0"
  fix ta h' s'
  assume "?lhs ta h' s'"
  then have "exec_meth ci (compP2 P) (compE2 e @ ?E) (compxE2 e 0 0 @ shift (length (compE2 e)) ?xt) t h (stk, loc, pc, xcp) ta h' s'"
    by (simp add: exec_move_def shift_compxE2 algebra_simps uminus_minus_left_commute)
  thus "?rhs ta h' s'" unfolding exec_move_def using pc by(rule exec_meth_take_xt)
qed(rule exec_move_WhileI1)

lemma exec_move_WhileI2:
  assumes exec: "exec_move ci P t e1 h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
  shows "exec_move ci P t (while (e) e1) h (stk, loc, (Suc (length (compE2 e) + pc)), xcp) ta h' (stk', loc', (Suc (length (compE2 e) + pc')), xcp')"
proof -
  let ?E = "compE2 e @ [IfFalse (3 + int (length (compE2 e1)))]"
  let ?E' = "[Pop, Goto (- int (length (compE2 e)) + (-2 - int (length (compE2 e1)))), Push Unit]"
  from exec have "exec_meth ci (compP2 P) (compE2 e1) (compxE2 e1 0 0) t h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
    by(simp add: exec_move_def)
  hence "exec_meth ci (compP2 P) ((?E @ compE2 e1) @ ?E') (compxE2 e 0 0 @ shift (length ?E) (compxE2 e1 0 0)) t h (stk, loc, length ?E + pc, xcp) ta h' (stk', loc', length ?E + pc', xcp')"
    by -(rule exec_meth_append, rule append_exec_meth_xt, auto)
  thus ?thesis by (simp add: shift_compxE2 exec_move_def algebra_simps uminus_minus_left_commute)
qed

lemma exec_move_While2:
  assumes pc: "pc < length (compE2 e')"
  shows "exec_move ci P t (while (e) e') h (stk, loc, (Suc (length (compE2 e) + pc)), xcp) ta
                                    h' (stk', loc', (Suc (length (compE2 e) + pc')), xcp') =
         exec_move ci P t e' h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
  (is "?lhs = ?rhs")
proof
  let ?E = "compE2 e @ [IfFalse (3 + int (length (compE2 e')))]"
  let ?E' = "[Pop, Goto (- int (length (compE2 e)) + (-2 - int (length (compE2 e')))), Push Unit]"
  assume ?lhs
  hence "exec_meth ci (compP2 P) ((?E @ compE2 e') @ ?E') (compxE2 e 0 0 @ shift (length ?E) (compxE2 e' 0 0)) t h (stk, loc, length ?E + pc, xcp) ta h' (stk', loc', length ?E + pc', xcp')"
    by(simp add: exec_move_def shift_compxE2 algebra_simps uminus_minus_left_commute)
  thus ?rhs unfolding exec_move_def using pc
    by -(drule exec_meth_take, simp, drule exec_meth_drop_xt, auto)
qed(rule exec_move_WhileI2)

lemma exec_move_ThrowI:
  "exec_move ci P t e h s ta h' s'  exec_move ci P t (throw e) h s ta h' s'"
unfolding exec_move_def by auto

lemma exec_move_Throw:
  "pc < length (compE2 e)  exec_move ci P t (throw e) h (stk, loc, pc, xcp) = exec_move ci P t e h (stk, loc, pc, xcp)"
unfolding exec_move_def by(auto intro!: ext intro: exec_meth_take)

lemma exec_move_TryI1:
  "exec_move ci P t e h s ta h' s'  exec_move ci P t (try e catch(C V) e') h s ta h' s'"
unfolding exec_move_def by auto

lemma exec_move_TryI2:
  assumes exec: "exec_move ci P t e h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
  shows "exec_move ci P t (try e' catch(C V) e) h (stk, loc, Suc (Suc (length (compE2 e') + pc)), xcp) ta h' (stk', loc', Suc (Suc (length (compE2 e') + pc')), xcp')"
proof -
  let ?e = "compE2 e' @ [Goto (int(size (compE2 e))+2), Store V]"
  from exec have "exec_meth ci (compP2 P) (compE2 e) (compxE2 e 0 0) t h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
    by(simp add: exec_move_def)
  hence "exec_meth ci (compP2 P) ((?e @ compE2 e) @ []) ((compxE2 e' 0 0 @ shift (length ?e) (compxE2 e 0 0)) @ [(0, length (compE2 e'), C, Suc (length (compE2 e')), 0)]) t h (stk, loc, (length ?e + pc), xcp) ta h' (stk', loc', (length ?e + pc'), xcp')"
    by(rule exec_meth_append_xt[OF append_exec_meth_xt]) auto
  thus ?thesis by(simp add: eval_nat_numeral shift_compxE2 exec_move_def)
qed

lemma exec_move_Try2:
  "exec_move ci P t (try e catch(C V) e') h (stk, loc, Suc (Suc (length (compE2 e) + pc)), xcp) ta
                                     h' (stk', loc', Suc (Suc (length (compE2 e) + pc')), xcp') =
   exec_move ci P t e' h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
  (is "?lhs = ?rhs")
proof
  let ?E = "compE2 e @ [Goto (int(size (compE2 e'))+2), Store V]"
  let ?xt = "[(0, length (compE2 e), C, Suc (length (compE2 e)), 0)]"
  assume lhs: ?lhs
  hence pc: "pc < length (compE2 e')"
    by(fastforce elim!: exec_meth.cases simp add: exec_move_def match_ex_table_append match_ex_entry dest: match_ex_table_pcsD)
  from lhs have "exec_meth ci (compP2 P) ((?E @ compE2 e') @ []) ((compxE2 e 0 0 @ shift (length ?E) (compxE2 e' 0 0)) @ ?xt) t h (stk, loc, length ?E + pc, xcp) ta h' (stk', loc', length ?E + pc', xcp')"
    by(simp add: exec_move_def shift_compxE2 ac_simps)
  thus ?rhs unfolding exec_move_def using pc
    by-(drule exec_meth_drop_xt[OF exec_meth_take_xt'], auto)
qed(rule exec_move_TryI2)

lemma exec_move_raise_xcp_pcD:
  "exec_move ci P t E h (stk, loc, pc, None) ta h' (stk', loc', pc', Some a)  pc' = pc"
apply(cases "compE2 E ! pc")
apply(auto simp add: exec_move_def elim!: exec_meth.cases split: if_split_asm sum.split_asm)
apply(auto split: extCallRet.split_asm simp add: split_beta)
done


definition τexec_meth :: 
  "('addr, 'heap) check_instr  'addr jvm_prog  'addr instr list  ex_table  'thread_id  'heap
   ('addr val list × 'addr val list × pc × 'addr option)
   ('addr val list × 'addr val list × pc × 'addr option)  bool"
where
  "τexec_meth ci P ins xt t h s s'  
  exec_meth ci P ins xt t h s ε h s'  (snd (snd (snd s)) = None  τinstr P h (fst s) (ins ! fst (snd (snd s))))"

abbreviation τexec_meth_a
where "τexec_meth_a  τexec_meth (Abs_check_instr check_instr')"

abbreviation τexec_meth_d
where "τexec_meth_d  τexec_meth (Abs_check_instr check_instr)"

lemma τexec_methI [intro]:
  " exec_meth ci P ins xt t h (stk, loc, pc, xcp) ε h s'; xcp = None  τinstr P h stk (ins ! pc) 
    τexec_meth ci P ins xt t h (stk, loc, pc, xcp) s'"
by(simp add: τexec_meth_def)

lemma τexec_methE [elim]:
  assumes "τexec_meth ci P ins xt t h s s'"
  obtains stk loc pc xcp
  where "s = (stk, loc, pc, xcp)"
  and "exec_meth ci P ins xt t h (stk, loc, pc, xcp) ε h s'"
  and "xcp = None  τinstr P h stk (ins ! pc)"
using assms
by(cases s)(auto simp add: τexec_meth_def)

abbreviation τExec_methr :: 
  "('addr, 'heap) check_instr  'addr jvm_prog  'addr instr list  ex_table  'thread_id  'heap 
   ('addr val list × 'addr val list × pc × 'addr option)
   ('addr val list × 'addr val list × pc × 'addr option)  bool"
where
  "τExec_methr ci P ins xt t h == (τexec_meth ci P ins xt t h)^**"

abbreviation τExec_metht :: 
  "('addr, 'heap) check_instr  'addr jvm_prog  'addr instr list  ex_table  'thread_id  'heap
   ('addr val list × 'addr val list × pc × 'addr option)
   ('addr val list × 'addr val list × pc × 'addr option)  bool"
where
  "τExec_metht ci P ins xt t h == (τexec_meth ci P ins xt t h)^++"

abbreviation τExec_methr_a
where "τExec_methr_a  τExec_methr (Abs_check_instr check_instr')"

abbreviation τExec_methr_d
where "τExec_methr_d  τExec_methr (Abs_check_instr check_instr)"

abbreviation τExec_metht_a
where "τExec_metht_a  τExec_metht (Abs_check_instr check_instr')"

abbreviation τExec_metht_d
where "τExec_metht_d  τExec_metht (Abs_check_instr check_instr)"

lemma τExec_methr_refl: "τExec_methr ci P ins xt t h s s" ..

lemma τExec_methr_step':
  " τExec_methr ci P ins xt t h s (stk', loc', pc', xcp');
     τexec_meth ci P ins xt t h (stk', loc', pc', xcp') s' 
   τExec_methr ci P ins xt t h s s'"
by(rule rtranclp.rtrancl_into_rtrancl)

lemma τExec_methr_step:
  " τExec_methr ci P ins xt t h s (stk', loc', pc', xcp');
     exec_meth ci P ins xt t h (stk', loc', pc', xcp') ε h s';
     xcp' = None  τinstr P h stk' (ins ! pc') 
   τExec_methr ci P ins xt t h s s'"
by(erule τExec_methr_step')(rule τexec_methI)

lemmas τExec_methr_intros = τExec_methr_refl τExec_methr_step
lemmas τExec_methr1step = τExec_methr_step[OF τExec_methr_refl]
lemmas τExec_methr2step = τExec_methr_step[OF τExec_methr_step, OF τExec_methr_refl]
lemmas τExec_methr3step = τExec_methr_step[OF τExec_methr_step, OF τExec_methr_step, OF τExec_methr_refl]

lemma τExec_methr_cases [consumes 1, case_names refl step]:
  assumes "τExec_methr ci P ins xt t h s s'"
  obtains "s = s'"
  | stk' loc' pc' xcp'
    where "τExec_methr ci P ins xt t h s (stk', loc', pc', xcp')"
       "exec_meth ci P ins xt t h (stk', loc', pc', xcp') ε h s'"
       "xcp' = None  τinstr P h stk' (ins ! pc')"
using assms
by(rule rtranclp.cases)(auto elim!: τexec_methE)

lemma τExec_methr_induct [consumes 1, case_names refl step]:
  " τExec_methr ci P ins xt t h s s';
     Q s;
     stk loc pc xcp s'.  τExec_methr ci P ins xt t h s (stk, loc, pc, xcp); exec_meth ci P ins xt t h (stk, loc, pc, xcp) ε h s';
                          xcp = None  τinstr P h stk (ins ! pc); Q (stk, loc, pc, xcp)   Q s' 
   Q s'"
by(erule (1) rtranclp_induct)(blast elim: τexec_methE)

lemma τExec_methr_trans: 
  " τExec_methr ci P ins xt t h s s'; τExec_methr ci P ins xt t h s' s''   τExec_methr ci P ins xt t h s s''"
by(rule rtranclp_trans)

lemmas τExec_meth_induct_split = τExec_methr_induct[split_format (complete), consumes 1, case_names τExec_refl τExec_step]

lemma τExec_methr_converse_cases [consumes 1, case_names refl step]:
  assumes "τExec_methr ci P ins xt t h s s'"
  obtains "s = s'"
  | stk loc pc xcp s''
    where "s = (stk, loc, pc, xcp)"
       "exec_meth ci P ins xt t h (stk, loc, pc, xcp) ε h s''"
       "xcp = None  τinstr P h stk (ins ! pc)"
       "τExec_methr ci P ins xt t h s'' s'"
using assms
by(erule converse_rtranclpE)(blast elim: τexec_methE)

definition τexec_move :: 
  "('addr, 'heap) check_instr  'addr J1_prog  'thread_id  'addr expr1  'heap
   ('addr val list × 'addr val list × pc × 'addr option)
   ('addr val list × 'addr val list × pc × 'addr option)  bool"
where
  "τexec_move ci P t e h =
  (λ(stk, loc, pc, xcp) s'. exec_move ci P t e h (stk, loc, pc, xcp) ε h s'  τmove2 P h stk e pc xcp)"

definition τexec_moves :: 
  "('addr, 'heap) check_instr  'addr J1_prog  'thread_id  'addr expr1 list  'heap
   ('addr val list × 'addr val list × pc × 'addr option)
   ('addr val list × 'addr val list × pc × 'addr option)  bool"
where
  "τexec_moves ci P t es h =
   (λ(stk, loc, pc, xcp) s'. exec_moves ci P t es h (stk, loc, pc, xcp) ε h s'  τmoves2 P h stk es pc xcp)"

lemma τexec_moveI:
  " exec_move ci P t e h (stk, loc, pc, xcp) ε h s'; τmove2 P h stk e pc xcp  
   τexec_move ci P t e h (stk, loc, pc, xcp) s'"
by(simp add: τexec_move_def)

lemma τexec_moveE:
  assumes "τexec_move ci P t e h (stk, loc, pc, xcp) s'"
  obtains "exec_move ci P t e h (stk, loc, pc, xcp) ε h s'" "τmove2 P h stk e pc xcp"
using assms by(simp add: τexec_move_def)

lemma τexec_movesI:
  " exec_moves ci P t es h (stk, loc, pc, xcp) ε h s'; τmoves2 P h stk es pc xcp  
   τexec_moves ci P t es h (stk, loc, pc, xcp) s'"
by(simp add: τexec_moves_def)

lemma τexec_movesE:
  assumes "τexec_moves ci P t es h (stk, loc, pc, xcp) s'"
  obtains "exec_moves ci P t es h (stk, loc, pc, xcp) ε h s'" "τmoves2 P h stk es pc xcp"
using assms by(simp add: τexec_moves_def)

lemma τexec_move_conv_τexec_meth:
  "τexec_move ci P t e = τexec_meth ci (compP2 P) (compE2 e) (compxE2 e 0 0) t"
by(auto simp add: τexec_move_def exec_move_def τmove2_iff compP2_def intro!: ext τexec_methI elim!: τexec_methE)

lemma τexec_moves_conv_τexec_meth:
  "τexec_moves ci P t es = τexec_meth ci (compP2 P) (compEs2 es) (compxEs2 es 0 0) t"
by(auto simp add: τexec_moves_def exec_moves_def τmoves2_iff compP2_def intro!: ext τexec_methI elim!: τexec_methE)

abbreviation τExec_mover
where "τExec_mover ci P t e h == (τexec_move ci P t e h)^**"

abbreviation τExec_movet
where "τExec_movet ci P t e h == (τexec_move ci P t e h)^++"

abbreviation τExec_mover_a
where "τExec_mover_a  τExec_mover (Abs_check_instr check_instr')"

abbreviation τExec_mover_d
where "τExec_mover_d  τExec_mover (Abs_check_instr check_instr)"

abbreviation τExec_movet_a
where "τExec_movet_a  τExec_movet (Abs_check_instr check_instr')"

abbreviation τExec_movet_d
where "τExec_movet_d  τExec_movet (Abs_check_instr check_instr)"

abbreviation τExec_movesr
where "τExec_movesr ci P t e h == (τexec_moves ci P t e h)^**"

abbreviation τExec_movest
where "τExec_movest ci P t e h == (τexec_moves ci P t e h)^++"

abbreviation τExec_movesr_a
where "τExec_movesr_a  τExec_movesr (Abs_check_instr check_instr')"

abbreviation τExec_movesr_d
where "τExec_movesr_d  τExec_movesr (Abs_check_instr check_instr)"

abbreviation τExec_movest_a
where "τExec_movest_a  τExec_movest (Abs_check_instr check_instr')"

abbreviation τExec_movest_d
where "τExec_movest_d  τExec_movest (Abs_check_instr check_instr)"

lemma τExecr_refl: "τExec_mover ci P t e h s s"
by(rule rtranclp.rtrancl_refl)

lemma τExecsr_refl: "τExec_movesr ci P t e h s s"
by(rule rtranclp.rtrancl_refl)

lemma τExecr_step: 
  " τExec_mover ci P t e h s (stk', loc', pc', xcp');
     exec_move ci P t e h (stk', loc', pc', xcp') ε h s';
     τmove2 P h stk' e pc' xcp' 
   τExec_mover ci P t e h s s'"
by(rule rtranclp.rtrancl_into_rtrancl)(auto elim: τexec_moveI)

lemma τExecsr_step: 
  " τExec_movesr ci P t es h s (stk', loc', pc', xcp');
     exec_moves ci P t es h (stk', loc', pc', xcp') ε h s';
     τmoves2 P h stk' es pc' xcp' 
   τExec_movesr ci P t es h s s'"
by(rule rtranclp.rtrancl_into_rtrancl)(auto elim: τexec_movesI)

lemma τExect_step:
  " τExec_movet ci P t e h s (stk', loc', pc', xcp');
     exec_move ci P t e h (stk', loc', pc', xcp') ε h s';
     τmove2 P h stk' e pc' xcp' 
   τExec_movet ci P t e h s s'"
by(rule tranclp.trancl_into_trancl)(auto intro: τexec_moveI)

lemma τExecst_step:
  " τExec_movest ci P t es h s (stk', loc', pc', xcp');
     exec_moves ci P t es h (stk', loc', pc', xcp') ε h s';
     τmoves2 P h stk' es pc' xcp' 
   τExec_movest ci P t es h s s'"
by(rule tranclp.trancl_into_trancl)(auto intro: τexec_movesI)

lemmas τExecr1step = τExecr_step[OF τExecr_refl]
lemmas τExecr2step = τExecr_step[OF τExecr_step, OF τExecr_refl]
lemmas τExecr3step = τExecr_step[OF τExecr_step, OF τExecr_step, OF τExecr_refl]

lemmas τExecsr1step = τExecsr_step[OF τExecsr_refl]
lemmas τExecsr2step = τExecsr_step[OF τExecsr_step, OF τExecsr_refl]
lemmas τExecsr3step = τExecsr_step[OF τExecsr_step, OF τExecsr_step, OF τExecsr_refl]

lemma τExect1step:
  " exec_move ci P t e h s ε h s';
     τmove2 P h (fst s) e (fst (snd (snd s))) (snd (snd (snd s))) 
   τExec_movet ci P t e h s s'"
by(rule tranclp.r_into_trancl)(cases s, auto intro: τexec_moveI)

lemmas τExect2step = τExect_step[OF τExect1step]
lemmas τExect3step = τExect_step[OF τExect_step, OF τExect1step]

lemma τExecst1step:
  " exec_moves ci P t es h s ε h s';
     τmoves2 P h (fst s) es (fst (snd (snd s))) (snd (snd (snd s))) 
   τExec_movest ci P t es h s s'"
by(rule tranclp.r_into_trancl)(cases s, auto intro: τexec_movesI)

lemmas τExecst2step = τExecst_step[OF τExecst1step]
lemmas τExecst3step = τExecst_step[OF τExecst_step, OF τExecst1step]

lemma τExecr_induct [consumes 1, case_names refl step]:
  assumes major: "τExec_mover ci P t e h (stk, loc, pc, xcp) (stk'', loc'', pc'', xcp'')"
  and refl: "Q stk loc pc xcp"
  and step: "stk' loc' pc' xcp' stk'' loc'' pc'' xcp''.
              τExec_mover ci P t e h (stk, loc, pc, xcp) (stk', loc', pc', xcp');
               τexec_move ci P t e h (stk', loc', pc', xcp') (stk'', loc'', pc'', xcp''); Q stk' loc' pc' xcp' 
              Q stk'' loc'' pc'' xcp''"
  shows "Q stk'' loc'' pc'' xcp''"
using major refl
by(rule rtranclp_induct4)(rule step)

lemma τExecsr_induct [consumes 1, case_names refl step]:
  assumes major: "τExec_movesr ci P t es h (stk, loc, pc, xcp) (stk'', loc'', pc'', xcp'')"
  and refl: "Q stk loc pc xcp"
  and step: "stk' loc' pc' xcp' stk'' loc'' pc'' xcp''.
              τExec_movesr ci P t es h (stk, loc, pc, xcp) (stk', loc', pc', xcp');
               τexec_moves ci P t es h (stk', loc', pc', xcp') (stk'', loc'', pc'', xcp''); Q stk' loc' pc' xcp' 
              Q stk'' loc'' pc'' xcp''"
  shows "Q stk'' loc'' pc'' xcp''"
using major refl
by(rule rtranclp_induct4)(rule step)

lemma τExect_induct [consumes 1, case_names base step]:
  assumes major: "τExec_movet ci P t e h (stk, loc, pc, xcp) (stk'', loc'', pc'', xcp'')"
  and base: "stk' loc' pc' xcp'. τexec_move ci P t e h (stk, loc, pc, xcp) (stk', loc', pc', xcp')  Q stk' loc' pc' xcp'"
  and step: "stk' loc' pc' xcp' stk'' loc'' pc'' xcp''.
              τExec_movet ci P t e h (stk, loc, pc, xcp) (stk', loc', pc', xcp');
               τexec_move ci P t e h (stk', loc', pc', xcp') (stk'', loc'', pc'', xcp''); Q stk' loc' pc' xcp' 
              Q stk'' loc'' pc'' xcp''"
  shows "Q stk'' loc'' pc'' xcp''"
using major
by(rule tranclp_induct4)(erule base step)+

lemma τExecst_induct [consumes 1, case_names base step]:
  assumes major: "τExec_movest ci P t es h (stk, loc, pc, xcp) (stk'', loc'', pc'', xcp'')"
  and base: "stk' loc' pc' xcp'. τexec_moves ci P t es h (stk, loc, pc, xcp) (stk', loc', pc', xcp')  Q stk' loc' pc' xcp'"
  and step: "stk' loc' pc' xcp' stk'' loc'' pc'' xcp''.
              τExec_movest ci P t es h (stk, loc, pc, xcp) (stk', loc', pc', xcp');
               τexec_moves ci P t es h (stk', loc', pc', xcp') (stk'', loc'', pc'', xcp''); Q stk' loc' pc' xcp' 
              Q stk'' loc'' pc'' xcp''"
  shows "Q stk'' loc'' pc'' xcp''"
using major
by(rule tranclp_induct4)(erule base step)+

lemma τExec_mover_τExec_methr:
  "τExec_mover ci P t e = τExec_methr ci (compP2 P) (compE2 e) (compxE2 e 0 0) t"
by(simp only: τexec_move_conv_τexec_meth)

lemma τExec_movesr_τExec_methr:
  "τExec_movesr ci P t es = τExec_methr ci (compP2 P) (compEs2 es) (compxEs2 es 0 0) t"
by(simp only: τexec_moves_conv_τexec_meth)

lemma τExec_movet_τExec_metht:
  "τExec_movet ci P t e = τExec_metht ci (compP2 P) (compE2 e) (compxE2 e 0 0) t"
by(simp only: τexec_move_conv_τexec_meth)

lemma τExec_movest_τExec_metht:
  "τExec_movest ci P t es = τExec_metht ci (compP2 P) (compEs2 es) (compxEs2 es 0 0) t"
by(simp only: τexec_moves_conv_τexec_meth)

lemma τExec_mover_trans: 
  " τExec_mover ci P t e h s s'; τExec_mover ci P t e h s' s''   τExec_mover ci P t e h s s''"
by(rule rtranclp_trans)

lemma τExec_movesr_trans: 
  " τExec_movesr ci P t es h s s'; τExec_movesr ci P t es h s' s''   τExec_movesr ci P t es h s s''"
by(rule rtranclp_trans)

lemma τExec_movet_trans: 
  " τExec_movet ci P t e h s s'; τExec_movet ci P t e h s' s''   τExec_movet ci P t e h s s''"
by(rule tranclp_trans)

lemma τExec_movest_trans: 
  " τExec_movest ci P t es h s s'; τExec_movest ci P t es h s' s''   τExec_movest ci P t es h s s''"
by(rule tranclp_trans)

lemma τexec_move_into_τexec_moves:
  "τexec_move ci P t e h s s'  τexec_moves ci P t (e # es) h s s'"
by(cases s)(auto elim!: τexec_moveE intro!: τexec_movesI simp add: exec_move_def exec_moves_def intro: τmoves2Hd)

lemma τExec_mover_τExec_movesr:
  "τExec_mover ci P t e h s s'  τExec_movesr ci P t (e # es) h s s'"
by(induct rule: rtranclp_induct)(blast intro: rtranclp.rtrancl_into_rtrancl τexec_move_into_τexec_moves)+

lemma τExec_movet_τExec_movest:
  "τExec_movet ci P t e h s s'  τExec_movest ci P t (e # es) h s s'"
by(induct rule: tranclp_induct)(blast intro: tranclp.trancl_into_trancl τexec_move_into_τexec_moves)+

lemma exec_moves_append: "exec_moves ci P t es h s ta h' s'  exec_moves ci P t (es @ es') h s ta h' s'"
by(auto simp add: exec_moves_def)

lemma τexec_moves_append: "τexec_moves ci P t es h s s'  τexec_moves ci P t (es @ es') h s s'"
by(cases s)(auto elim!: τexec_movesE intro!: τexec_movesI exec_moves_append)

lemma τExec_movesr_append [intro]:
  "τExec_movesr ci P t es h s s'  τExec_movesr ci P t (es @ es') h s s'"
by(induct rule: rtranclp_induct)(blast intro: rtranclp.rtrancl_into_rtrancl τexec_moves_append)+

lemma τExec_movest_append [intro]:
  "τExec_movest ci P t es h s s'  τExec_movest ci P t (es @ es') h s s'"
by(induct rule: tranclp_induct)(blast intro: tranclp.trancl_into_trancl τexec_moves_append)+

lemma append_exec_moves:
  assumes len: "length vs = length es'"
  and exec: "exec_moves ci P t es h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
  shows "exec_moves ci P t (es' @ es) h ((stk @ vs), loc, (length (compEs2 es') + pc), xcp) ta h' ((stk' @ vs), loc', (length (compEs2 es') + pc'), xcp')"
proof -
  from exec have "exec_meth ci (compP2 P) (compEs2 es) (compxEs2 es 0 0) t h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
    unfolding exec_moves_def .
  hence "exec_meth ci (compP2 P) (compEs2 es) (stack_xlift (length vs) (compxEs2 es 0 0)) t h ((stk @ vs), loc, pc, xcp) ta h' ((stk' @ vs), loc', pc', xcp')" by(rule exec_meth_stk_offer)
  hence "exec_meth ci (compP2 P) (compEs2 es' @ compEs2 es) (compxEs2 es' 0 0 @ shift (length (compEs2 es')) (stack_xlift (length (vs)) (compxEs2 es 0 0))) t h ((stk @ vs), loc, (length (compEs2 es') + pc), xcp) ta h' ((stk' @ vs), loc', (length (compEs2 es') + pc'), xcp')"
    by(rule append_exec_meth_xt) auto
  thus ?thesis by(simp add: exec_moves_def stack_xlift_compxEs2 shift_compxEs2 len)
qed


lemma append_τexec_moves:
  " length vs = length es';
    τexec_moves ci P t es h (stk, loc, pc, xcp) (stk', loc', pc', xcp') 
   τexec_moves ci P t (es' @ es) h ((stk @ vs), loc, (length (compEs2 es') + pc), xcp) ((stk' @ vs), loc', (length (compEs2 es') + pc'), xcp')"
by(auto elim!: τexec_movesE intro: τexec_movesI append_exec_moves τmoves2_stk_append append_τmoves2)

lemma append_τExec_movesr:
  assumes len: "length vs = length es'"
  shows "τExec_movesr ci P t es h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τExec_movesr ci P t (es' @ es) h ((stk @ vs), loc, (length (compEs2 es') + pc), xcp) ((stk' @ vs), loc', (length (compEs2 es') + pc'), xcp')"
by(induct rule: rtranclp_induct4)(blast intro: rtranclp.rtrancl_into_rtrancl append_τexec_moves[OF len])+

lemma append_τExec_movest:
  assumes len: "length vs = length es'"
  shows "τExec_movest ci P t es h  (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τExec_movest ci P t (es' @ es) h ((stk @ vs), loc, (length (compEs2 es') + pc), xcp)  ((stk' @ vs), loc', (length (compEs2 es') + pc'), xcp')"
by(induct rule: tranclp_induct4)(blast intro: tranclp.trancl_into_trancl append_τexec_moves[OF len])+


lemma NewArray_τexecI:
  "τexec_move ci P t e h s s'  τexec_move ci P t (newA Te) h s s'"
by(cases s)(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_newArrayI)

lemma Cast_τexecI:
  "τexec_move ci P t e h s s'  τexec_move ci P t (Cast T e) h s s'"
by(cases s)(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_CastI)

lemma InstanceOf_τexecI:
  "τexec_move ci P t e h s s'  τexec_move ci P t (e instanceof T) h s s'"
by(cases s)(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_InstanceOfI)

lemma BinOp_τexecI1:
  "τexec_move ci P t e h s s'  τexec_move ci P t (e «bop» e') h s s'"
by(cases s)(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_BinOpI1)

lemma BinOp_τexecI2:
  "τexec_move ci P t e' h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τexec_move ci P t (e «bop» e') h ((stk @ [v]), loc, (length (compE2 e) + pc), xcp) ((stk' @ [v]), loc', (length (compE2 e) + pc'), xcp')"
by(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_BinOpI2 τmove2_stk_append)

lemma LAss_τexecI:
  "τexec_move ci P t e h s s'  τexec_move ci P t (V := e) h s s'"
by(cases s)(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_LAssI)

lemma AAcc_τexecI1:
  "τexec_move ci P t e h s s'  τexec_move ci P t (ei) h s s'"
by(cases s)(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_AAccI1)

lemma AAcc_τexecI2:
  "τexec_move ci P t e' h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τexec_move ci P t (ee') h ((stk @ [v]), loc, (length (compE2 e) + pc), xcp) ((stk' @ [v]), loc', (length (compE2 e) + pc'), xcp')"
by(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_AAccI2 τmove2_stk_append)

lemma AAss_τexecI1:
  "τexec_move ci P t e h s s'  τexec_move ci P t (ei := e') h s s'"
by(cases s)(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_AAssI1)

lemma AAss_τexecI2:
  "τexec_move ci P t e' h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τexec_move ci P t (ee' := e'') h ((stk @ [v]), loc, (length (compE2 e) + pc), xcp) ((stk' @ [v]), loc', (length (compE2 e) + pc'), xcp')"
by(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_AAssI2 τmove2_stk_append)

lemma AAss_τexecI3:
  "τexec_move ci P t e'' h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τexec_move ci P t (ee' := e'') h ((stk @ [v, v']), loc, (length (compE2 e) + length (compE2 e') + pc), xcp) ((stk' @ [v, v']), loc', (length (compE2 e) + length (compE2 e') + pc'), xcp')"
by(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_AAssI3 τmove2_stk_append)

lemma ALength_τexecI:
  "τexec_move ci P t e h s s'  τexec_move ci P t (e∙length) h s s'"
by(cases s)(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_ALengthI)

lemma FAcc_τexecI:
  "τexec_move ci P t e h s s'  τexec_move ci P t (eF{D}) h s s'"
by(cases s)(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_FAccI)

lemma FAss_τexecI1:
  "τexec_move ci P t e h s s'  τexec_move ci P t (eF{D} := e') h s s'"
by(cases s)(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_FAssI1)

lemma FAss_τexecI2:
  "τexec_move ci P t e' h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τexec_move ci P t (eF{D} := e') h ((stk @ [v]), loc, (length (compE2 e) + pc), xcp) ((stk' @ [v]), loc', (length (compE2 e) + pc'), xcp')"
by(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_FAssI2 τmove2_stk_append)

lemma CAS_τexecI1:
  "τexec_move ci P t e h s s'  τexec_move ci P t (e∙compareAndSwap(DF, e', e'')) h s s'"
by(cases s)(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_CASI1)

lemma CAS_τexecI2:
  "τexec_move ci P t e' h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τexec_move ci P t (e∙compareAndSwap(DF, e', e'')) h ((stk @ [v]), loc, (length (compE2 e) + pc), xcp) ((stk' @ [v]), loc', (length (compE2 e) + pc'), xcp')"
by(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_CASI2 τmove2_stk_append)

lemma CAS_τexecI3:
  "τexec_move ci P t e'' h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τexec_move ci P t (e∙compareAndSwap(DF, e', e'')) h ((stk @ [v, v']), loc, (length (compE2 e) + length (compE2 e') + pc), xcp) ((stk' @ [v, v']), loc', (length (compE2 e) + length (compE2 e') + pc'), xcp')"
by(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_CASI3 τmove2_stk_append)

lemma Call_τexecI1:
  "τexec_move ci P t e h s s'  τexec_move ci P t (eM(es)) h s s'"
by(cases s)(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_CallI1)

lemma Call_τexecI2:
  "τexec_moves ci P t es h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τexec_move ci P t (eM(es)) h ((stk @ [v]), loc, (length (compE2 e) + pc), xcp) ((stk' @ [v]), loc', (length (compE2 e) + pc'), xcp')"
by(blast elim: τexec_movesE intro: τexec_moveI τmove2_τmoves2.intros exec_move_CallI2 τmoves2_stk_append)

lemma Block_τexecI_Some:
  "τexec_move ci P t e h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τexec_move ci P t {V:T=v; e} h (stk, loc, Suc (Suc pc), xcp) (stk', loc', Suc (Suc pc'), xcp')"
by(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_BlockSomeI)

lemma Block_τexecI_None:
  "τexec_move ci P t e h s s'  τexec_move ci P t {V:T=None; e} h s s'"
by(cases s)(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_BlockNoneI)

lemma Sync_τexecI:
  "τexec_move ci P t e h s s'  τexec_move ci P t (syncV (e) e') h s s'"
by(cases s)(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_SyncI1)

lemma Insync_τexecI:
  "τexec_move ci P t e' h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τexec_move ci P t (syncV (e) e') h (stk, loc, Suc (Suc (Suc (length (compE2 e) + pc))), xcp) (stk', loc', Suc (Suc (Suc (length (compE2 e) + pc'))), xcp')"
by(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_SyncI2)

lemma Seq_τexecI1:
  "τexec_move ci P t e h s s'  τexec_move ci P t (e;; e') h s s'"
by(cases s)(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_SeqI1)

lemma Seq_τexecI2:
  "τexec_move ci P t e' h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τexec_move ci P t (e;; e') h (stk, loc, Suc (length (compE2 e) + pc), xcp) (stk', loc', Suc (length (compE2 e) + pc'), xcp')"
by(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_SeqI2)

lemma Cond_τexecI1:
  "τexec_move ci P t e h s s'  τexec_move ci P t (if (e) e' else e'') h s s'"
by(cases s)(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_CondI1)

lemma Cond_τexecI2:
  "τexec_move ci P t e' h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τexec_move ci P t (if (e) e' else e'') h (stk, loc, Suc (length (compE2 e) + pc), xcp) (stk', loc', Suc (length (compE2 e) + pc'), xcp')"
by(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_CondI2)

lemma Cond_τexecI3:
  "τexec_move ci P t e'' h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τexec_move ci P t (if (e) e' else e'') h (stk, loc, Suc (Suc (length (compE2 e) + length (compE2 e') + pc)), xcp) (stk', loc', Suc (Suc (length (compE2 e) + length (compE2 e') + pc')), xcp')"
by(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_CondI3)

lemma While_τexecI1:
  "τexec_move ci P t e h s s'  τexec_move ci P t (while (e) e') h s s'"
by(cases s)(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_WhileI1)

lemma While_τexecI2:
  "τexec_move ci P t e' h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τexec_move ci P t (while (e) e') h (stk, loc, Suc (length (compE2 e) + pc), xcp) (stk', loc', Suc (length (compE2 e) + pc'), xcp')"
by(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_WhileI2)

lemma Throw_τexecI:
  "τexec_move ci P t e h s s'  τexec_move ci P t (throw e) h s s'"
by(cases s)(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_ThrowI)

lemma Try_τexecI1:
  "τexec_move ci P t e h s s'  τexec_move ci P t (try e catch(C V) e') h s s'"
by(cases s)(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_TryI1)

lemma Try_τexecI2:
  "τexec_move ci P t e' h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τexec_move ci P t (try e catch(C V) e') h (stk, loc, Suc (Suc (length (compE2 e) + pc)), xcp) (stk', loc', Suc (Suc (length (compE2 e) + pc')), xcp')"
by(blast elim: τexec_moveE intro: τexec_moveI τmove2_τmoves2.intros exec_move_TryI2)



lemma NewArray_τExecrI:
  "τExec_mover ci P t e h s s'  τExec_mover ci P t (newA Te) h s s'"
by(induct rule: rtranclp_induct)(blast intro: rtranclp.rtrancl_into_rtrancl NewArray_τexecI)+

lemma Cast_τExecrI:
  "τExec_mover ci P t e h s s'  τExec_mover ci P t (Cast T e) h s s'"
by(induct rule: rtranclp_induct)(blast intro: rtranclp.rtrancl_into_rtrancl Cast_τexecI)+

lemma InstanceOf_τExecrI:
  "τExec_mover ci P t e h s s'  τExec_mover ci P t (e instanceof T) h s s'"
by(induct rule: rtranclp_induct)(blast intro: rtranclp.rtrancl_into_rtrancl InstanceOf_τexecI)+

lemma BinOp_τExecrI1:
  "τExec_mover ci P t e1 h s s'  τExec_mover ci P t (e1 «bop» e2) h s s'"
by(induct rule: rtranclp_induct)(blast intro: rtranclp.rtrancl_into_rtrancl BinOp_τexecI1)+

lemma BinOp_τExecrI2:
  "τExec_mover ci P t e2 h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τExec_mover ci P t (e «bop» e2)  h ((stk @ [v]), loc, (length (compE2 e) + pc), xcp) ((stk' @ [v]), loc', (length (compE2 e) + pc'), xcp')"
by(induct rule: τExecr_induct)(blast intro: rtranclp.rtrancl_into_rtrancl BinOp_τexecI2)+

lemma LAss_τExecrI:
  "τExec_mover ci P t e h s s'  τExec_mover ci P t (V := e) h s s'"
by(induct rule: rtranclp_induct)(blast intro: rtranclp.rtrancl_into_rtrancl LAss_τexecI)+

lemma AAcc_τExecrI1:
  "τExec_mover ci P t e h s s'  τExec_mover ci P t (ei) h s s'"
by(induct rule: rtranclp_induct)(blast intro: rtranclp.rtrancl_into_rtrancl AAcc_τexecI1)+

lemma AAcc_τExecrI2:
  "τExec_mover ci P t i h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τExec_mover ci P t (ai) h ((stk @ [v]), loc, (length (compE2 a) + pc), xcp) ((stk' @ [v]), loc', (length (compE2 a) + pc'), xcp')"
by(induct rule: τExecr_induct)(blast intro: rtranclp.rtrancl_into_rtrancl AAcc_τexecI2)+

lemma AAss_τExecrI1:
  "τExec_mover ci P t e h s s'  τExec_mover ci P t (ei := e') h s s'"
by(induct rule: rtranclp_induct)(blast intro: rtranclp.rtrancl_into_rtrancl AAss_τexecI1)+

lemma AAss_τExecrI2:
  "τExec_mover ci P t i h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τExec_mover ci P t (ai := e) h ((stk @ [v]), loc, (length (compE2 a) + pc), xcp) ((stk' @ [v]), loc', (length (compE2 a) + pc'), xcp')"
by(induct rule: τExecr_induct)(blast intro: rtranclp.rtrancl_into_rtrancl AAss_τexecI2)+

lemma AAss_τExecrI3:
  "τExec_mover ci P t e h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τExec_mover ci P t (ai := e) h ((stk @ [v, v']), loc, (length (compE2 a) + length (compE2 i) + pc), xcp) ((stk' @ [v, v']), loc', (length (compE2 a) + length (compE2 i) + pc'), xcp')"
by(induct rule: τExecr_induct)(blast intro: rtranclp.rtrancl_into_rtrancl AAss_τexecI3)+

lemma ALength_τExecrI:
  "τExec_mover ci P t e h s s'  τExec_mover ci P t (e∙length) h s s'"
by(induct rule: rtranclp_induct)(blast intro: rtranclp.rtrancl_into_rtrancl ALength_τexecI)+

lemma FAcc_τExecrI:
  "τExec_mover ci P t e h s s'  τExec_mover ci P t (eF{D}) h s s'"
by(induct rule: rtranclp_induct)(blast intro: rtranclp.rtrancl_into_rtrancl FAcc_τexecI)+

lemma FAss_τExecrI1:
  "τExec_mover ci P t e h s s'  τExec_mover ci P t (eF{D} := e') h s s'"
by(induct rule: rtranclp_induct)(blast intro: rtranclp.rtrancl_into_rtrancl FAss_τexecI1)+

lemma FAss_τExecrI2:
  "τExec_mover ci P t e' h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τExec_mover ci P t (eF{D} := e') h ((stk @ [v]), loc, (length (compE2 e) + pc), xcp) ((stk' @ [v]), loc', (length (compE2 e) + pc'), xcp')"
by(induct rule: τExecr_induct)(blast intro: rtranclp.rtrancl_into_rtrancl FAss_τexecI2)+

lemma CAS_τExecrI1:
  "τExec_mover ci P t e h s s'  τExec_mover ci P t (e∙compareAndSwap(DF, e', e'')) h s s'"
by(induct rule: rtranclp_induct)(blast intro: rtranclp.rtrancl_into_rtrancl CAS_τexecI1)+

lemma CAS_τExecrI2:
  "τExec_mover ci P t e' h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τExec_mover ci P t (e∙compareAndSwap(DF, e', e'')) h ((stk @ [v]), loc, (length (compE2 e) + pc), xcp) ((stk' @ [v]), loc', (length (compE2 e) + pc'), xcp')"
by(induct rule: τExecr_induct)(blast intro: rtranclp.rtrancl_into_rtrancl CAS_τexecI2)+

lemma CAS_τExecrI3:
  "τExec_mover ci P t e'' h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τExec_mover ci P t (e∙compareAndSwap(DF, e', e'')) h ((stk @ [v, v']), loc, (length (compE2 e) + length (compE2 e') + pc), xcp) ((stk' @ [v, v']), loc', (length (compE2 e) + length (compE2 e') + pc'), xcp')"
by(induct rule: τExecr_induct)(blast intro: rtranclp.rtrancl_into_rtrancl CAS_τexecI3)+

lemma Call_τExecrI1:
  "τExec_mover ci P t obj h s s'  τExec_mover ci P t (objM'(es)) h s s'"
by(induct rule: rtranclp_induct)(blast intro: rtranclp.rtrancl_into_rtrancl Call_τexecI1)+

lemma Call_τExecrI2:
  "τExec_movesr ci P t es h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τExec_mover ci P t (objM'(es)) h ((stk @ [v]), loc, (length (compE2 obj) + pc), xcp) ((stk' @ [v]), loc', (length (compE2 obj) + pc'), xcp')"
by(induct rule: τExecsr_induct)(blast intro: rtranclp.rtrancl_into_rtrancl Call_τexecI2)+

lemma Block_τExecrI_Some:
  "τExec_mover ci P t e h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τExec_mover ci P t {V:T=v; e} h (stk, loc, (Suc (Suc pc)), xcp) (stk', loc', (Suc (Suc pc')), xcp')"
by(induct rule: τExecr_induct)(blast intro: rtranclp.rtrancl_into_rtrancl Block_τexecI_Some)+

lemma Block_τExecrI_None:
  "τExec_mover ci P t e h s s'  τExec_mover ci P t {V:T=None; e} h s s'"
by(induct rule: rtranclp_induct)(blast intro: rtranclp.rtrancl_into_rtrancl Block_τexecI_None)+

lemma Sync_τExecrI:
  "τExec_mover ci P t e h s s'  τExec_mover ci P t (syncV (e) e') h s s'"
by(induct rule: rtranclp_induct)(blast intro: rtranclp.rtrancl_into_rtrancl Sync_τexecI)+

lemma Insync_τExecrI:
  "τExec_mover ci P t e' h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τExec_mover ci P t (syncV (e) e')  h (stk, loc, (Suc (Suc (Suc (length (compE2 e) + pc)))), xcp) (stk', loc', (Suc (Suc (Suc (length (compE2 e) + pc')))), xcp')"
by(induct rule: τExecr_induct)(blast intro: rtranclp.rtrancl_into_rtrancl Insync_τexecI)+

lemma Seq_τExecrI1:
  "τExec_mover ci P t e h s s'  τExec_mover ci P t (e;;e') h s s'"
by(induct rule: rtranclp_induct)(blast intro: rtranclp.rtrancl_into_rtrancl Seq_τexecI1)+

lemma Seq_τExecrI2:
  "τExec_mover ci P t e h (stk, loc, pc, xcp) (stk', loc', pc' ,xcp') 
   τExec_mover ci P t (e';;e) h (stk, loc, (Suc (length (compE2 e') + pc)), xcp) (stk', loc', (Suc (length (compE2 e') + pc')), xcp')"
by(induct rule: τExecr_induct)(blast intro: rtranclp.rtrancl_into_rtrancl Seq_τexecI2)+

lemma Cond_τExecrI1:
  "τExec_mover ci P t e h s s'  τExec_mover ci P t (if (e) e1 else e2) h s s'"
by(induct rule: rtranclp_induct)(blast intro: rtranclp.rtrancl_into_rtrancl Cond_τexecI1)+

lemma Cond_τExecrI2:
  "τExec_mover ci P t e1  h (stk, loc, pc, xcp) (stk', loc', pc', xcp') 
   τExec_mover ci P t (if (e) e1 else e2)  h (stk, loc, (Suc (length (compE2 e) + pc)), xcp) (stk', loc', (Suc (length (compE2 e) + pc')), xcp')"
by(induct rule: τExecr_induct)(blast intro: rtranclp.rtrancl_into_rtrancl Cond_τexecI2)+

lemma Cond_τExecrI3:
  "τExec_mover ci P t e2  h (stk, loc ,pc, xcp) (stk', loc', pc', xcp') 
   τExec_mover ci P t (if (e) e1 else e2)  h (stk, loc, (Suc (Suc (length (compE2 e) + length (compE2 e1) + pc))), xcp)  (stk', loc', (Suc (Suc (length (compE2 e) + length (compE2 e1) + pc'))), xcp')"
by(induct rule: τExecr_induct)(blast intro: rtranclp.rtrancl_into_rtrancl Cond_τexecI3)+

lemma While_τExecrI1:
  "τExec_mover ci P t c h s s'  τExec_mover ci P t (while (c) e) h s s'"
by(induct rule: rtranclp_induct)(blast intro: rtranclp.rtrancl_into_rtrancl While_τexecI1)+

lemma While_τExecrI2:
  "τExec_mover ci P t E h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τExec_mover ci P t (while (c) E)  h (stk, loc ,(Suc (length (compE2 c) + pc)), xcp) (stk', loc', (Suc (length (compE2 c) + pc')), xcp')"
by(induct rule: τExecr_induct)(blast intro: rtranclp.rtrancl_into_rtrancl While_τexecI2)+

lemma Throw_τExecrI:
  "τExec_mover ci P t e h s s'  τExec_mover ci P t (throw e) h s s'"
by(induct rule: rtranclp_induct)(blast intro: rtranclp.rtrancl_into_rtrancl Throw_τexecI)+

lemma Try_τExecrI1:
  "τExec_mover ci P t E h s s'  τExec_mover ci P t (try E catch(C' V) e) h s s'"
by(induct rule: rtranclp_induct)(blast intro: rtranclp.rtrancl_into_rtrancl Try_τexecI1)+

lemma Try_τExecrI2:
  "τExec_mover ci P t e h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τExec_mover ci P t (try E catch(C' V) e)  h (stk, loc, (Suc (Suc (length (compE2 E) + pc))), xcp)  (stk', loc', (Suc (Suc (length (compE2 E) + pc'))), xcp')"
by(induct rule: τExecr_induct)(blast intro: rtranclp.rtrancl_into_rtrancl Try_τexecI2)+


lemma NewArray_τExectI:
  "τExec_movet ci P t e h s s'  τExec_movet ci P t (newA Te) h s s'"
by(induct rule: tranclp_induct)(blast intro: tranclp.trancl_into_trancl NewArray_τexecI)+

lemma Cast_τExectI:
  "τExec_movet ci P t e h s s'  τExec_movet ci P t (Cast T e) h s s'"
by(induct rule: tranclp_induct)(blast intro: tranclp.trancl_into_trancl Cast_τexecI)+

lemma InstanceOf_τExectI:
  "τExec_movet ci P t e h s s'  τExec_movet ci P t (e instanceof T) h s s'"
by(induct rule: tranclp_induct)(blast intro: tranclp.trancl_into_trancl InstanceOf_τexecI)+

lemma BinOp_τExectI1:
  "τExec_movet ci P t e1 h s s'  τExec_movet ci P t (e1 «bop» e2) h s s'"
by(induct rule: tranclp_induct)(blast intro: tranclp.trancl_into_trancl BinOp_τexecI1)+

lemma BinOp_τExectI2:
  "τExec_movet ci P t e2 h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τExec_movet ci P t (e «bop» e2)  h ((stk @ [v]), loc, (length (compE2 e) + pc), xcp) ((stk' @ [v]), loc', (length (compE2 e) + pc'), xcp')"
by(induct rule: τExect_induct)(blast intro: tranclp.trancl_into_trancl BinOp_τexecI2)+

lemma LAss_τExectI:
  "τExec_movet ci P t e h s s'  τExec_movet ci P t (V := e) h s s'"
by(induct rule: tranclp_induct)(blast intro: tranclp.trancl_into_trancl LAss_τexecI)+

lemma AAcc_τExectI1:
  "τExec_movet ci P t e h s s'  τExec_movet ci P t (ei) h s s'"
by(induct rule: tranclp_induct)(blast intro: tranclp.trancl_into_trancl AAcc_τexecI1)+

lemma AAcc_τExectI2:
  "τExec_movet ci P t i h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τExec_movet ci P t (ai) h ((stk @ [v]), loc, (length (compE2 a) + pc), xcp) ((stk' @ [v]), loc', (length (compE2 a) + pc'), xcp')"
by(induct rule: τExect_induct)(blast intro: tranclp.trancl_into_trancl AAcc_τexecI2)+

lemma AAss_τExectI1:
  "τExec_movet ci P t e h s s'  τExec_movet ci P t (ei := e') h s s'"
by(induct rule: tranclp_induct)(blast intro: tranclp.trancl_into_trancl AAss_τexecI1)+

lemma AAss_τExectI2:
  "τExec_movet ci P t i h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τExec_movet ci P t (ai := e) h ((stk @ [v]), loc, (length (compE2 a) + pc), xcp) ((stk' @ [v]), loc', (length (compE2 a) + pc'), xcp')"
by(induct rule: τExect_induct)(blast intro: tranclp.trancl_into_trancl AAss_τexecI2)+

lemma AAss_τExectI3:
  "τExec_movet ci P t e h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τExec_movet ci P t (ai := e) h ((stk @ [v, v']), loc, (length (compE2 a) + length (compE2 i) + pc), xcp) ((stk' @ [v, v']), loc', (length (compE2 a) + length (compE2 i) + pc'), xcp')"
by(induct rule: τExect_induct)(blast intro: tranclp.trancl_into_trancl AAss_τexecI3)+

lemma ALength_τExectI:
  "τExec_movet ci P t e h s s'  τExec_movet ci P t (e∙length) h s s'"
by(induct rule: tranclp_induct)(blast intro: tranclp.trancl_into_trancl ALength_τexecI)+

lemma FAcc_τExectI:
  "τExec_movet ci P t e h s s'  τExec_movet ci P t (eF{D}) h s s'"
by(induct rule: tranclp_induct)(blast intro: tranclp.trancl_into_trancl FAcc_τexecI)+

lemma FAss_τExectI1:
  "τExec_movet ci P t e h s s'  τExec_movet ci P t (eF{D} := e') h s s'"
by(induct rule: tranclp_induct)(blast intro: tranclp.trancl_into_trancl FAss_τexecI1)+

lemma FAss_τExectI2:
  "τExec_movet ci P t e' h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τExec_movet ci P t (eF{D} := e') h ((stk @ [v]), loc, (length (compE2 e) + pc), xcp) ((stk' @ [v]), loc', (length (compE2 e) + pc'), xcp')"
by(induct rule: τExect_induct)(blast intro: tranclp.trancl_into_trancl FAss_τexecI2)+

lemma CAS_τExectI1:
  "τExec_movet ci P t e h s s'  τExec_movet ci P t (e∙compareAndSwap(DF, e', e'')) h s s'"
by(induct rule: tranclp_induct)(blast intro: tranclp.trancl_into_trancl CAS_τexecI1)+

lemma CAS_τExectI2:
  "τExec_movet ci P t e' h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τExec_movet ci P t (e∙compareAndSwap(DF, e', e'')) h ((stk @ [v]), loc, (length (compE2 e) + pc), xcp) ((stk' @ [v]), loc', (length (compE2 e) + pc'), xcp')"
by(induct rule: τExect_induct)(blast intro: tranclp.trancl_into_trancl CAS_τexecI2)+

lemma CAS_τExectI3:
  "τExec_movet ci P t e'' h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τExec_movet ci P t (e∙compareAndSwap(DF, e', e'')) h ((stk @ [v, v']), loc, (length (compE2 e) + length (compE2 e') + pc), xcp) ((stk' @ [v, v']), loc', (length (compE2 e) + length (compE2 e') + pc'), xcp')"
by(induct rule: τExect_induct)(blast intro: tranclp.trancl_into_trancl CAS_τexecI3)+

lemma Call_τExectI1:
  "τExec_movet ci P t obj h s s'  τExec_movet ci P t (objM'(es)) h s s'"
by(induct rule: tranclp_induct)(blast intro: tranclp.trancl_into_trancl Call_τexecI1)+

lemma Call_τExectI2:
  "τExec_movest ci P t es h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τExec_movet ci P t (objM'(es)) h ((stk @ [v]), loc, (length (compE2 obj) + pc), xcp) ((stk' @ [v]), loc', (length (compE2 obj) + pc'), xcp')"
by(induct rule: τExecst_induct)(blast intro: tranclp.trancl_into_trancl Call_τexecI2)+

lemma Block_τExectI_Some:
  "τExec_movet ci P t e h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τExec_movet ci P t {V:T=v; e} h (stk, loc, (Suc (Suc pc)), xcp) (stk', loc', (Suc (Suc pc')), xcp')"
by(induct rule: τExect_induct)(blast intro: tranclp.trancl_into_trancl Block_τexecI_Some)+

lemma Block_τExectI_None:
  "τExec_movet ci P t e h s s'  τExec_movet ci P t {V:T=None; e} h s s'"
by(induct rule: tranclp_induct)(blast intro: tranclp.trancl_into_trancl Block_τexecI_None)+

lemma Sync_τExectI:
  "τExec_movet ci P t e h s s'  τExec_movet ci P t (syncV (e) e') h s s'"
by(induct rule: tranclp_induct)(blast intro: tranclp.trancl_into_trancl Sync_τexecI)+

lemma Insync_τExectI:
  "τExec_movet ci P t e' h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τExec_movet ci P t (syncV (e) e')  h (stk, loc, (Suc (Suc (Suc (length (compE2 e) + pc)))), xcp) (stk', loc', (Suc (Suc (Suc (length (compE2 e) + pc')))), xcp')"
by(induct rule: τExect_induct)(blast intro: tranclp.trancl_into_trancl Insync_τexecI)+

lemma Seq_τExectI1:
  "τExec_movet ci P t e h s s'  τExec_movet ci P t (e;;e') h s s'"
by(induct rule: tranclp_induct)(blast intro: tranclp.trancl_into_trancl Seq_τexecI1)+

lemma Seq_τExectI2:
  "τExec_movet ci P t e h (stk, loc, pc, xcp) (stk', loc', pc' ,xcp') 
   τExec_movet ci P t (e';;e) h (stk, loc, (Suc (length (compE2 e') + pc)), xcp) (stk', loc', (Suc (length (compE2 e') + pc')), xcp')"
by(induct rule: τExect_induct)(blast intro: tranclp.trancl_into_trancl Seq_τexecI2)+

lemma Cond_τExectI1:
  "τExec_movet ci P t e h s s'  τExec_movet ci P t (if (e) e1 else e2) h s s'"
by(induct rule: tranclp_induct)(blast intro: tranclp.trancl_into_trancl Cond_τexecI1)+

lemma Cond_τExectI2:
  "τExec_movet ci P t e1  h (stk, loc, pc, xcp) (stk', loc', pc', xcp') 
   τExec_movet ci P t (if (e) e1 else e2)  h (stk, loc, (Suc (length (compE2 e) + pc)), xcp) (stk', loc', (Suc (length (compE2 e) + pc')), xcp')"
by(induct rule: τExect_induct)(blast intro: tranclp.trancl_into_trancl Cond_τexecI2)+

lemma Cond_τExectI3:
  "τExec_movet ci P t e2  h (stk, loc ,pc, xcp) (stk', loc', pc', xcp') 
   τExec_movet ci P t (if (e) e1 else e2)  h (stk, loc, (Suc (Suc (length (compE2 e) + length (compE2 e1) + pc))), xcp)  (stk', loc', (Suc (Suc (length (compE2 e) + length (compE2 e1) + pc'))), xcp')"
by(induct rule: τExect_induct)(blast intro: tranclp.trancl_into_trancl Cond_τexecI3)+

lemma While_τExectI1:
  "τExec_movet ci P t c h s s'  τExec_movet ci P t (while (c) e) h s s'"
by(induct rule: tranclp_induct)(blast intro: tranclp.trancl_into_trancl While_τexecI1)+

lemma While_τExectI2:
  "τExec_movet ci P t E h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τExec_movet ci P t (while (c) E)  h (stk, loc ,(Suc (length (compE2 c) + pc)), xcp) (stk', loc', (Suc (length (compE2 c) + pc')), xcp')"
by(induct rule: τExect_induct)(blast intro: tranclp.trancl_into_trancl While_τexecI2)+

lemma Throw_τExectI:
  "τExec_movet ci P t e h s s'  τExec_movet ci P t (throw e) h s s'"
by(induct rule: tranclp_induct)(blast intro: tranclp.trancl_into_trancl Throw_τexecI)+

lemma Try_τExectI1:
  "τExec_movet ci P t E h s s'  τExec_movet ci P t (try E catch(C' V) e) h s s'"
by(induct rule: tranclp_induct)(blast intro: tranclp.trancl_into_trancl Try_τexecI1)+

lemma Try_τExectI2:
  "τExec_movet ci P t e h (stk, loc, pc, xcp) (stk', loc', pc', xcp')
   τExec_movet ci P t (try E catch(C' V) e)  h (stk, loc, (Suc (Suc (length (compE2 E) + pc))), xcp)  (stk', loc', (Suc (Suc (length (compE2 E) + pc'))), xcp')"
by(induct rule: τExect_induct)(blast intro: tranclp.trancl_into_trancl Try_τexecI2)+

lemma τExec_movesr_map_Val:
  "τExec_movesr_a P t (map Val vs) h ([], xs, 0, None) ((rev vs), xs, (length (compEs2 (map Val vs))), None)"
proof(induct vs arbitrary: pc stk Ts rule: rev_induct)
  case Nil thus ?case by(auto)
next
  case (snoc v vs')
  let ?E = "compEs2 (map Val vs')"
  from snoc have "τExec_movesr_a P t (map Val (vs' @ [v])) h ([], xs, 0, None) ((rev vs'), xs, (length ?E), None)"
    by auto
  also {
    have "exec_meth_a (compP2 P) (?E @ [Push v]) (compxEs2 (map Val vs') 0 0 @ shift (length ?E) []) t h ((rev vs'), xs, (length ?E + 0), None) ε h ((v # rev vs'), xs, (length ?E + Suc 0), None)"
      by -(rule append_exec_meth_xt, auto simp add: exec_meth_instr)
    moreover have "τmoves2 (compP2 P) h (rev vs') (map Val vs' @ [Val v]) (length (compEs2 (map Val vs')) + 0) None"
      by(rule append_τmoves2 τmoves2Hd τmove2Val)+
    ultimately have "τExec_movesr_a P t (map Val (vs' @ [v])) h ((rev vs'), xs, (length ?E), None) ((rev (vs' @ [v])), xs, (length (compEs2 (map Val (vs' @ [v])))), None)"
      by -(rule τExecsr1step, auto simp add: exec_moves_def compP2_def) }
  finally show ?case .
qed

lemma τExec_mover_blocks1 [simp]:
  "τExec_mover ci P t (blocks1 n Ts body) h s s' = τExec_mover ci P t body h s s'"
by(simp add: τexec_move_conv_τexec_meth)

lemma τExec_movet_blocks1 [simp]:
  "τExec_movet ci P t (blocks1 n Ts body) h s s' = τExec_movet ci P t body h s s'"
by(simp add: τexec_move_conv_τexec_meth)


definition τexec_1 :: "'addr jvm_prog  'thread_id  ('addr, 'heap) jvm_state  ('addr, 'heap) jvm_state  bool"
  where "τexec_1 P t σ σ'  exec_1 P t σ ε σ'  τMove2 P σ"

lemma τexec_1I [intro]:
  " exec_1 P t σ ε σ'; τMove2 P σ   τexec_1 P t σ σ'"
by(simp add: τexec_1_def)

lemma τexec_1E [elim]:
  assumes "τexec_1 P t σ σ'"
  obtains "exec_1 P t σ ε σ'" "τMove2 P σ"
using assms by(auto simp add: τexec_1_def)

abbreviation τExec_1r :: "'addr jvm_prog  'thread_id  ('addr, 'heap) jvm_state  ('addr, 'heap) jvm_state  bool"
where "τExec_1r P t == (τexec_1 P t)^**"

abbreviation τExec_1t :: "'addr jvm_prog  'thread_id  ('addr, 'heap) jvm_state  ('addr, 'heap) jvm_state  bool"
where "τExec_1t P t == (τexec_1 P t)^++"

definition τexec_1_d :: "'addr jvm_prog  'thread_id  ('addr, 'heap) jvm_state  ('addr, 'heap) jvm_state  bool"
where "τexec_1_d P t σ σ'  exec_1 P t σ ε σ'  τMove2 P σ  check P σ"

lemma τexec_1_dI [intro]:
  " exec_1 P t σ ε σ'; check P σ; τMove2 P σ   τexec_1_d P t σ σ'"
by(simp add: τexec_1_d_def)

lemma τexec_1_dE [elim]:
  assumes "τexec_1_d P t σ σ'"
  obtains "exec_1 P t σ ε σ'" "check P σ" "τMove2 P σ"
using assms by(auto simp add: τexec_1_d_def)

abbreviation τExec_1_dr :: "'addr jvm_prog  'thread_id  ('addr, 'heap) jvm_state  ('addr, 'heap) jvm_state  bool"
where "τExec_1_dr P t == (τexec_1_d P t)^**"

abbreviation τExec_1_dt :: "'addr jvm_prog  'thread_id  ('addr, 'heap) jvm_state  ('addr, 'heap) jvm_state  bool"
where "τExec_1_dt P t == (τexec_1_d P t)^++"

declare compxE2_size_convs[simp del] compxEs2_size_convs[simp del]
declare compxE2_stack_xlift_convs[simp del] compxEs2_stack_xlift_convs[simp del]

lemma exec_instr_frs_offer:
  "(ta, xcp', h', (stk', loc', C, M, pc') # frs)  exec_instr ins P t h stk loc C M pc frs
   (ta, xcp', h', (stk', loc', C, M, pc') # frs @ frs')  exec_instr ins P t h stk loc C M pc (frs @ frs')"
apply(cases ins)
apply(simp_all add: nth_append split_beta split: if_split_asm sum.split_asm)
apply(force split: extCallRet.split_asm simp add: extRet2JVM_def)+
done

lemma check_instr_frs_offer:
  " check_instr ins P h stk loc C M pc frs; ins  Return 
   check_instr ins P h stk loc C M pc (frs @ frs')"
by(cases ins)(simp_all split: if_split_asm)

lemma exec_instr_CM_change:
  "(ta, xcp', h', (stk', loc', C, M, pc') # frs)  exec_instr ins P t h stk loc C M pc frs
   (ta, xcp', h', (stk', loc', C', M', pc') # frs)  exec_instr ins P t h stk loc C' M' pc frs"
apply(cases ins)
apply(simp_all add: nth_append split_beta neq_Nil_conv split: if_split_asm sum.split_asm)
apply(force split: extCallRet.split_asm simp add: extRet2JVM_def)+
done

lemma check_instr_CM_change:
  " check_instr ins P h stk loc C M pc frs; ins  Return 
   check_instr ins P h stk loc C' M' pc frs"
by(cases ins)(simp_all split: if_split_asm)

lemma exec_move_exec_1:
  assumes exec: "exec_move ci P t body h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
  and sees: "P  C sees M : TsT = body in D"
  shows "exec_1 (compP2 P) t (xcp, h, (stk, loc, C, M, pc) # frs) ta (xcp', h', (stk', loc', C, M, pc') # frs)"
using exec unfolding exec_move_def
proof(cases)
  case exec_instr
  note [simp] = xcp = None›
    and exec = (ta, xcp', h', [(stk', loc', undefined, undefined, pc')])
                 exec_instr (compE2 body ! pc) (compP2 P) t h stk loc undefined undefined pc []
  from exec have "(ta, xcp', h', [(stk', loc', C, M, pc')])
                 exec_instr (compE2 body ! pc) (compP2 P) t h stk loc C M pc []"
    by(rule exec_instr_CM_change)
  from exec_instr_frs_offer[OF this, of frs]
  have "(ta, xcp', h', (stk', loc', C, M, pc') # frs)
         exec_instr (compE2 body ! pc) (compP2 P) t h stk loc C M pc frs" by simp
  with sees pc < length (compE2 body) show ?thesis
    by(simp add: exec_1_iff compP2_def compMb2_def nth_append)
next
  case exec_catch
  thus ?thesis using sees_method_compP[OF sees, of "λC M Ts T. compMb2"]
    by(simp add: exec_1_iff compMb2_def compP2_def)
qed

lemma τexec_move_τexec_1:
  assumes exec: "τexec_move ci P t body h (stk, loc, pc, xcp) (stk', loc', pc', xcp')"
  and sees: "P  C sees M : TsT = body in D"
  shows "τexec_1 (compP2 P) t (xcp, h, (stk, loc, C, M, pc) # frs) (xcp', h, (stk', loc', C, M, pc') # frs)"
proof(rule τexec_1I)
  from exec obtain exec': "exec_move ci P t body h (stk, loc, pc, xcp) ε h (stk', loc', pc', xcp')"
    and τ: "τmove2 P h stk body pc xcp" by(rule τexec_moveE)
  have "exec_1 (compP2 P) t (xcp, h, (stk, loc, C, M, pc) # frs) ε (xcp', h, (stk', loc', C, M, pc') # frs)"
    using exec' sees by(rule exec_move_exec_1)
  thus "compP2 P,t  (xcp, h, (stk, loc, C, M, pc) # frs) -ε-jvm→ (xcp', h, (stk', loc', C, M, pc') # frs)" by auto
  { fix a
    assume [simp]: "xcp = a" 
    from sees_method_compP[OF sees, of "λC M Ts T. compMb2"]
    have "ex_table_of (compP2 P) C M = compxE2 body 0 0" by(simp add: compP2_def compMb2_def)
    hence "match_ex_table (compP2 P) (cname_of h a) pc (ex_table_of (compP2 P) C M)  None" "pc < length (compE2 body)"
      using exec' sees by(auto simp add: exec_move_def elim: exec_meth.cases) }
  with τ sees sees_method_compP[OF sees, of "λC M Ts T. compMb2"]
  show "τMove2 (compP2 P) (xcp, h, (stk, loc, C, M, pc) # frs)" 
    unfolding τMove2_compP2[OF sees] by(fastforce simp add: compP2_def compMb2_def)
qed

lemma τExec_mover_τExec_1r:
  assumes move: "τExec_mover ci P t body h (stk, loc, pc, xcp) (stk', loc', pc', xcp')"
  and sees: "P  C sees M : TsT = body in D"
  shows "τExec_1r (compP2 P) t (xcp, h, (stk, loc, C, M, pc) # frs') (xcp', h, (stk', loc', C, M, pc') # frs')"
using move
by(induct rule: τExecr_induct)(blast intro: rtranclp.rtrancl_into_rtrancl τexec_move_τexec_1[OF _ sees])+

lemma τExec_movet_τExec_1t:
  assumes move: "τExec_movet ci P t body h (stk, loc, pc, xcp) (stk', loc', pc', xcp')"
  and sees: "P  C sees M : TsT = body in D"
  shows "τExec_1t (compP2 P) t (xcp, h, (stk, loc, C, M, pc) # frs') (xcp', h, (stk', loc', C, M, pc') # frs')"
using move
by(induct rule: τExect_induct)(blast intro: tranclp.trancl_into_trancl τexec_move_τexec_1[OF _ sees])+

lemma τExec_1r_rtranclpD:
  "τExec_1r P t (xcp, h, frs) (xcp', h', frs')
   (λ((xcp, frs), h) ((xcp', frs'), h'). exec_1 P t (xcp, h, frs) ε (xcp', h', frs')  τMove2 P (xcp, h, frs))^** ((xcp, frs), h) ((xcp', frs'), h')"
by(induct rule: rtranclp_induct3)(fastforce intro: rtranclp.rtrancl_into_rtrancl)+

lemma τExec_1t_rtranclpD:
  "τExec_1t P t (xcp, h, frs) (xcp', h', frs')
   (λ((xcp, frs), h) ((xcp', frs'), h'). exec_1 P t (xcp, h, frs) ε (xcp', h', frs')  τMove2 P (xcp, h, frs))^++ ((xcp, frs), h) ((xcp', frs'), h')"
by(induct rule: tranclp_induct3)(fastforce intro: tranclp.trancl_into_trancl)+

lemma exec_meth_length_compE2_stack_xliftD:
  "exec_meth ci P (compE2 e) (stack_xlift d (compxE2 e 0 0)) t h (stk, loc, pc, xcp) ta h' s'
   pc < length (compE2 e)"
by(cases s')(auto simp add: stack_xlift_compxE2)

lemma exec_meth_length_pc_xt_Nil:
  "exec_meth ci P ins [] t h (stk, loc, pc, xcp) ta h' s'  pc < length ins"
apply(erule exec_meth.cases)
apply(auto dest: match_ex_table_pc_length_compE2)
done

lemma BinOp_exec2D:
  assumes exec: "exec_meth ci (compP2 P) (compE2 (e1 «bop» e2)) (compxE2 (e1 «bop» e2) 0 0) t h (stk @ [v1], loc, length (compE2 e1) + pc, xcp) ta h' (stk', loc', pc', xcp')"
  and pc: "pc < length (compE2 e2)"
  shows "exec_meth ci (compP2 P) (compE2 e2) (stack_xlift (length [v1]) (compxE2 e2 0 0)) t h (stk @ [v1], loc, pc, xcp) ta h' (stk', loc', pc' - length (compE2 e1), xcp')  pc'  length (compE2 e1)"
proof
  from exec have "exec_meth ci (compP2 P) ((compE2 e1 @ compE2 e2) @ [BinOpInstr bop])
     (compxE2 e1 0 0 @ shift (length (compE2 e1)) (stack_xlift (length [v1]) (compxE2 e2 0 0))) t h
     (stk @ [v1], loc, length (compE2 e1) + pc, xcp) ta h' (stk', loc', pc', xcp')"
    by(simp add: compxE2_size_convs compxE2_stack_xlift_convs)
  hence exec': "exec_meth ci (compP2 P) (compE2 e1 @ compE2 e2) (compxE2 e1 0 0 @ shift (length (compE2 e1)) (stack_xlift (length [v1]) (compxE2 e2 0 0))) t h
     (stk @ [v1], loc, length (compE2 e1) + pc, xcp) ta h' (stk', loc', pc', xcp')"
    by(rule exec_meth_take) (simp add: pc)
  thus "exec_meth ci (compP2 P) (compE2 e2) (stack_xlift (length [v1]) (compxE2 e2 0 0)) t h
     (stk @ [v1], loc, pc, xcp) ta h' (stk', loc', pc' - length (compE2 e1), xcp')"
    by(rule exec_meth_drop_xt) auto
  from exec' show "pc'  length (compE2 e1)"
   by(rule exec_meth_drop_xt_pc)(auto)
qed

lemma Call_execParamD:
  assumes exec: "exec_meth ci (compP2 P) (compE2 (objM'(ps))) (compxE2 (objM'(ps)) 0 0) t h (stk @ [v], loc, length (compE2 obj) + pc, xcp) ta h' (stk', loc', pc', xcp')"
  and pc: "pc < length (compEs2 ps)"
  shows "exec_meth ci (compP2 P) (compEs2 ps) (stack_xlift (length [v]) (compxEs2 ps 0 0)) t h (stk @ [v], loc, pc, xcp) ta h' (stk', loc', pc' - length (compE2 obj), xcp')  pc'  length (compE2 obj)"
proof
  from exec have "exec_meth ci (compP2 P) ((compE2 obj @ compEs2 ps) @ [Invoke M' (length ps)])
     (compxE2 obj 0 0 @ shift (length (compE2 obj)) (stack_xlift (length [v]) (compxEs2 ps 0 0))) t h
     (stk @ [v], loc, length (compE2 obj) + pc, xcp) ta h' (stk', loc', pc', xcp')"
    by(simp add: compxEs2_size_convs compxEs2_stack_xlift_convs)
  hence exec': "exec_meth ci (compP2 P) (compE2 obj @ compEs2 ps) (compxE2 obj 0 0 @ shift (length (compE2 obj)) (stack_xlift (length [v]) (compxEs2 ps 0 0))) t h
     (stk @ [v], loc, length (compE2 obj) + pc, xcp) ta h' (stk', loc', pc', xcp')"
    by(rule exec_meth_take)(simp add: pc)
  thus "exec_meth ci (compP2 P) (compEs2 ps) (stack_xlift (length [v]) (compxEs2 ps 0 0)) t h (stk @ [v], loc, pc, xcp) ta h' (stk', loc', pc' - length (compE2 obj), xcp')"
    by(rule exec_meth_drop_xt) auto
  from exec' show "pc'  length (compE2 obj)"
   by(rule exec_meth_drop_xt_pc)(auto)
qed

lemma exec_move_length_compE2D [dest]:
  "exec_move ci P t e h (stk, loc, pc, xcp) ta h' s'  pc < length (compE2 e)"
by(cases s')(auto simp add: exec_move_def)

lemma exec_moves_length_compEs2D [dest]:
  "exec_moves ci P t es h (stk, loc, pc, xcp) ta h' s'  pc < length (compEs2 es)"
by(cases s')(auto simp add: exec_moves_def)

lemma exec_meth_ci_appD:
  " exec_meth ci P ins xt t h (stk, loc, pc, None) ta h' fr' 
    ci_app ci (ins ! pc) P h stk loc undefined undefined pc []"
by(cases fr')(simp add: exec_meth_instr)

lemma exec_move_ci_appD:
  "exec_move ci P t E h (stk, loc, pc, None) ta h' fr'
   ci_app ci (compE2 E ! pc) (compP2 P) h stk loc undefined undefined pc []"
unfolding exec_move_def by(rule exec_meth_ci_appD)

lemma exec_moves_ci_appD:
  "exec_moves ci P t Es h (stk, loc, pc, None) ta h' fr'
   ci_app ci (compEs2 Es ! pc) (compP2 P) h stk loc undefined undefined pc []"
unfolding exec_moves_def by(rule exec_meth_ci_appD)

lemma τinstr_stk_append_check:
  "check_instr' i P h stk loc C M pc frs  τinstr P h (stk @ vs) i = τinstr P h stk i"
by(cases i)(simp_all add: nth_append)

lemma τinstr_stk_drop_exec_move:
  "exec_move ci P t e h (stk, loc, pc, None) ta h' fr'
   τinstr (compP2 P) h (stk @ vs) (compE2 e ! pc) = τinstr (compP2 P) h stk (compE2 e ! pc)"
apply(drule exec_move_ci_appD)
apply(drule wf_ciD2_ci_app)
apply(erule τinstr_stk_append_check)
done

lemma τinstr_stk_drop_exec_moves:
  "exec_moves ci P t es h (stk, loc, pc, None) ta h' fr'
   τinstr (compP2 P) h (stk @ vs) (compEs2 es ! pc) = τinstr (compP2 P) h stk (compEs2 es ! pc)"
apply(drule exec_moves_ci_appD)
apply(drule wf_ciD2_ci_app)
apply(erule τinstr_stk_append_check)
done

end

end

Theory J1JVMBisim

(*  Title:      JinjaThreads/Compiler/J1JVMBisim.thy
    Author:     Andreas Lochbihler
*)

section ‹The delay bisimulation between intermediate language and JVM›

theory J1JVMBisim imports 
  Execs
  "../BV/BVNoTypeError"
  J1
begin

declare Listn.lesub_list_impl_same_size[simp del]

lemma (in JVM_heap_conf_base') τexec_1_τexec_1_d:
  " wf_jvm_progΦ P; τexec_1 P t σ σ'; Φ |- t:σ [ok]   τexec_1_d P t σ σ'"
by(auto simp add: τexec_1_def τexec_1_d_def welltyped_commute[symmetric] elim: jvmd_NormalE)

context JVM_conf_read begin

lemma τExec_1r_preserves_correct_state:
  assumes wf: "wf_jvm_progΦ P"
  and exec: "τExec_1r P t σ σ'"
  shows "Φ |- t:σ [ok]  Φ |- t:σ' [ok]"
using exec
by(induct)(blast intro: BV_correct_1[OF wf])+

lemma τExec_1t_preserves_correct_state:
  assumes wf: "wf_jvm_progΦ P"
  and exec: "τExec_1t P t σ σ'"
  shows "Φ |- t:σ [ok]  Φ |- t:σ' [ok]"
using exec
by(induct)(blast intro: BV_correct_1[OF wf])+

lemma τExec_1r_τExec_1_dr:
  assumes wf: "wf_jvm_progΦ P"
  shows " τExec_1r P t σ σ'; Φ |- t:σ [ok]   τExec_1_dr P t σ σ'"
apply(induct rule: rtranclp_induct)
apply(blast intro: rtranclp.rtrancl_into_rtrancl τexec_1_τexec_1_d[OF wf] τExec_1r_preserves_correct_state[OF wf])+
done

lemma τExec_1t_τExec_1_dt:
  assumes wf: "wf_jvm_progΦ P"
  shows " τExec_1t P t σ σ'; Φ |- t:σ [ok]   τExec_1_dt P t σ σ'"
apply(induct rule: tranclp_induct)
apply(blast intro: tranclp.trancl_into_trancl τexec_1_τexec_1_d[OF wf] τExec_1t_preserves_correct_state[OF wf])+
done

lemma τExec_1_dr_preserves_correct_state:
  assumes wf: "wf_jvm_progΦ P"
  and exec: "τExec_1_dr P t σ σ'"
  shows "Φ |- t: σ [ok]  Φ |- t: σ' [ok]"
using exec
by(induct)(blast intro: BV_correct_1[OF wf])+

lemma τExec_1_dt_preserves_correct_state:
  assumes wf: "wf_jvm_progΦ P"
  and exec: "τExec_1_dt P t σ σ'"
  shows "Φ |- t:σ [ok]  Φ |- t:σ' [ok]"
using exec
by(induct)(blast intro: BV_correct_1[OF wf])+

end

locale J1_JVM_heap_base =
  J1_heap_base +
  JVM_heap_base +
  constrains addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
begin

inductive bisim1 ::
  "'m prog  'heap  'addr expr1  ('addr expr1 × 'addr locals1)
   ('addr val list × 'addr val list × pc × 'addr option)  bool"

  and bisims1 :: 
  "'m prog  'heap  'addr expr1 list  ('addr expr1 list × 'addr locals1)
   ('addr val list × 'addr val list × pc × 'addr option)  bool"
  
  and bisim1_syntax :: 
  "'m prog  'addr expr1  'heap  ('addr expr1 × 'addr locals1)
   ('addr val list × 'addr val list × pc × 'addr option)  bool"
  ("_,_,_  _  _" [50, 0, 0, 0, 50] 100)

  and bisims1_syntax :: 
  "'m prog  'addr expr1 list  'heap  ('addr expr1 list × 'addr locals1)
   ('addr val list × 'addr val list × pc × 'addr option)  bool"
  ("_,_,_  _ [↔] _" [50, 0, 0, 0, 50] 100)
  for P :: "'m prog" and  h :: 'heap
where
  "P, e, h  exs  s  bisim1 P h e exs s"
| "P, es, h  esxs [↔] s  bisims1 P h es esxs s"

| bisim1Val2:
  "pc = length (compE2 e)  P, e, h  (Val v, xs)  (v # [], xs, pc, None)"

| bisim1New:
  "P, new C, h  (new C, xs)  ([], xs, 0, None)"

| bisim1NewThrow:
  "P, new C, h  (THROW OutOfMemory, xs)  ([], xs, 0, addr_of_sys_xcpt OutOfMemory)"


| bisim1NewArray:
  "P, e, h  (e', xs)  (stk, loc, pc, xcp)  P, newA Te, h  (newA Te', xs)  (stk, loc, pc, xcp)"

| bisim1NewArrayThrow:
  "P, e, h  (Throw a, xs)  (stk, loc, pc, a)  P, newA Te, h  (Throw a, xs)  (stk, loc, pc, a)"

| bisim1NewArrayFail:
  "P, newA Te, h  (Throw a, xs)  ([v], xs, length (compE2 e), a)"


| bisim1Cast:
  "P, e, h  (e', xs)  (stk, loc, pc, xcp)  P, Cast T e, h  (Cast T e', xs)  (stk, loc, pc, xcp)"

| bisim1CastThrow:
  "P, e, h  (Throw a, xs)  (stk, loc, pc, a)  P, Cast T e, h  (Throw a, xs)  (stk, loc, pc, a)"

| bisim1CastFail:
  "P, Cast T e, h  (THROW ClassCast, xs)  ([v], xs, length (compE2 e), addr_of_sys_xcpt ClassCast)"


| bisim1InstanceOf:
  "P, e, h  (e', xs)  (stk, loc, pc, xcp)  P, e instanceof T, h  (e' instanceof T, xs)  (stk, loc, pc, xcp)"

| bisim1InstanceOfThrow:
  "P, e, h  (Throw a, xs)  (stk, loc, pc, a)  P, e instanceof T, h  (Throw a, xs)  (stk, loc, pc, a)"


| bisim1Val: "P, Val v, h  (Val v, xs)  ([], xs, 0, None)"

| bisim1Var: "P, Var V, h  (Var V, xs)  ([], xs, 0, None)"


| bisim1BinOp1:
  "P, e1, h  (e', xs)  (stk, loc, pc, xcp)  P, e1«bop»e2, h  (e'«bop»e2, xs)  (stk, loc, pc, xcp)"

| bisim1BinOp2:
  "P, e2, h  (e', xs)  (stk, loc, pc, xcp)
   P, e1«bop»e2, h  (Val v1 «bop» e', xs)  (stk @ [v1], loc, length (compE2 e1) + pc, xcp)"

| bisim1BinOpThrow1:
  "P, e1, h  (Throw a, xs)  (stk, loc, pc, a)
   P, e1«bop»e2, h  (Throw a, xs)  (stk, loc, pc, a)"

| bisim1BinOpThrow2:
  "P, e2, h  (Throw a, xs)  (stk, loc, pc, a)
   P, e1«bop»e2, h  (Throw a, xs)  (stk @ [v1], loc, length (compE2 e1) + pc, a)"

| bisim1BinOpThrow:
  "P, e1«bop»e2, h  (Throw a, xs)  ([v1, v2], xs, length (compE2 e1) + length (compE2 e2), a)"

| bisim1LAss1:
  "P, e, h  (e', xs)  (stk, loc, pc, xcp)  P, V:=e, h  (V:=e', xs)  (stk, loc, pc, xcp)"

| bisim1LAss2:
  "P, V:=e, h  (unit, xs)  ([], xs, Suc (length (compE2 e)), None)"

| bisim1LAssThrow:
  "P, e, h  (Throw a, xs)  (stk, loc, pc, a)  P, V:=e, h  (Throw a, xs)  (stk, loc, pc, a)"

| bisim1AAcc1:
  "P, a, h  (a', xs)  (stk, loc, pc, xcp)
   P, ai, h  (a'i, xs)  (stk, loc, pc, xcp)"

| bisim1AAcc2:
  "P, i, h  (i', xs)  (stk, loc, pc, xcp)
   P, ai, h  (Val vi', xs)  (stk @ [v], loc, length (compE2 a) + pc, xcp)"

| bisim1AAccThrow1:
  "P, a, h  (Throw ad, xs)  (stk, loc, pc, ad)
   P, ai, h  (Throw ad, xs)  (stk, loc, pc, ad)"

| bisim1AAccThrow2:
  "P, i, h  (Throw ad, xs)  (stk, loc, pc, ad)
   P, ai, h  (Throw ad, xs)  (stk @ [v], loc, length (compE2 a) + pc, ad)"

| bisim1AAccFail:
  "P, ai, h  (Throw ad, xs)  ([v, v'], xs, length (compE2 a) + length (compE2 i), ad)"


| bisim1AAss1:
  "P, a, h  (a', xs)  (stk, loc, pc, xcp)
   P, ai := e, h  (a'i := e, xs)  (stk, loc, pc, xcp)"

| bisim1AAss2:
  "P, i, h  (i', xs)  (stk, loc, pc, xcp)
   P, ai := e, h  (Val vi' := e, xs)  (stk @ [v], loc, length (compE2 a) + pc, xcp)"

| bisim1AAss3:
  "P, e, h  (e', xs)  (stk, loc, pc, xcp)
   P, ai := e, h  (Val vVal v' := e', xs)  (stk @ [v', v], loc, length (compE2 a) + length (compE2 i) + pc, xcp)"

| bisim1AAssThrow1:
  "P, a, h  (Throw ad, xs)  (stk, loc, pc, ad)
   P, ai := e, h  (Throw ad, xs)  (stk, loc, pc, ad)"

| bisim1AAssThrow2:
  "P, i, h  (Throw ad, xs)  (stk, loc, pc, ad)
   P, ai := e, h  (Throw ad, xs)  (stk @ [v], loc, length (compE2 a) + pc, ad)"

| bisim1AAssThrow3:
  "P, e, h  (Throw ad, xs)  (stk, loc, pc, ad)
   P, ai := e, h  (Throw ad, xs)  (stk @ [v', v], loc, length (compE2 a) + length (compE2 i) + pc, ad)"

| bisim1AAssFail:
  "P, ai := e, h  (Throw ad, xs)  ([v', v, v''], xs, length (compE2 a) + length (compE2 i) + length (compE2 e), ad)"

| bisim1AAss4:
  "P, ai := e, h  (unit, xs)  ([], xs, Suc (length (compE2 a) + length (compE2 i) + length (compE2 e)), None)"


| bisim1ALength: 
  "P, a, h  (a', xs)  (stk, loc, pc, xcp)
   P, a∙length, h  (a'∙length, xs)  (stk, loc, pc, xcp)"

| bisim1ALengthThrow:
  "P, a, h  (Throw ad, xs)  (stk, loc, pc, ad)
   P, a∙length, h  (Throw ad, xs)  (stk, loc, pc, ad)"


| bisim1ALengthNull:
  "P, a∙length, h  (THROW NullPointer, xs)  ([Null], xs, length (compE2 a), addr_of_sys_xcpt NullPointer)"


| bisim1FAcc: 
  "P, e, h  (e', xs)  (stk, loc, pc, xcp)
   P, eF{D}, h  (e'F{D}, xs)  (stk, loc, pc, xcp)"

| bisim1FAccThrow:
  "P, e, h  (Throw ad, xs)  (stk, loc, pc, ad)
   P, eF{D}, h  (Throw ad, xs)  (stk, loc, pc, ad)"

| bisim1FAccNull:
  "P, eF{D}, h  (THROW NullPointer, xs)  ([Null], xs, length (compE2 e), addr_of_sys_xcpt NullPointer)"


| bisim1FAss1: 
  "P, e, h  (e', xs)  (stk, loc, pc, xcp)
   P, eF{D} := e2, h  (e'F{D} := e2, xs)  (stk, loc, pc, xcp)"

| bisim1FAss2: 
  "P, e2, h  (e', xs)  (stk, loc, pc, xcp)
   P, eF{D} := e2, h  (Val vF{D} := e', xs)  (stk @ [v], loc, length (compE2 e) + pc, xcp)"

| bisim1FAssThrow1:
  "P, e, h  (Throw ad, xs)  (stk, loc, pc, ad)
   P, eF{D} := e2, h  (Throw ad, xs)  (stk, loc, pc, ad)"

| bisim1FAssThrow2:
  "P, e2, h  (Throw ad, xs)  (stk, loc, pc, ad)
   P, eF{D} := e2, h  (Throw ad, xs)  (stk @ [v], loc, length (compE2 e) + pc, ad)"

| bisim1FAssNull:
  "P, eF{D} := e2, h  (THROW NullPointer, xs)  ([v, Null], xs, length (compE2 e) + length (compE2 e2), addr_of_sys_xcpt NullPointer)"

| bisim1FAss3:
  "P, eF{D} := e2, h  (unit, xs)  ([], xs, Suc (length (compE2 e) + length (compE2 e2)), None)"


| bisim1CAS1:
  "P, e1, h  (e1', xs)  (stk, loc, pc, xcp)
   P, e1∙compareAndSwap(DF, e2, e3), h  (e1'∙compareAndSwap(DF, e2, e3), xs)  (stk, loc, pc, xcp)"

| bisim1CAS2:
  "P, e2, h  (e2', xs)  (stk, loc, pc, xcp)
   P, e1∙compareAndSwap(DF, e2, e3), h  (Val v∙compareAndSwap(DF, e2', e3), xs)  (stk @ [v], loc, length (compE2 e1) + pc, xcp)"

| bisim1CAS3:
  "P, e3, h  (e3', xs)  (stk, loc, pc, xcp)
   P, e1∙compareAndSwap(DF, e2, e3), h  (Val v∙compareAndSwap(DF, Val v', e3'), xs)  (stk @ [v', v], loc, length (compE2 e1) + length (compE2 e2) + pc, xcp)"

| bisim1CASThrow1:
  "P, e1, h  (Throw ad, xs)  (stk, loc, pc, ad)
   P, e1∙compareAndSwap(DF, e2, e3), h  (Throw ad, xs)  (stk, loc, pc, ad)"

| bisim1CASThrow2:
  "P, e2, h  (Throw ad, xs)  (stk, loc, pc, ad)
   P, e1∙compareAndSwap(DF, e2, e3), h  (Throw ad, xs)  (stk @ [v], loc, length (compE2 e1) + pc, ad)"

| bisim1CASThrow3:
  "P, e3, h  (Throw ad, xs)  (stk, loc, pc, ad)
   P, e1∙compareAndSwap(DF, e2, e3), h  (Throw ad, xs)  (stk @ [v', v], loc, length (compE2 e1) + length (compE2 e2) + pc, ad)"

| bisim1CASFail:
  "P, e1∙compareAndSwap(DF, e2, e3), h  (Throw ad, xs)  ([v', v, v''], xs, length (compE2 e1) + length (compE2 e2) + length (compE2 e3), ad)"


| bisim1Call1:
  "P, obj, h  (obj', xs)  (stk, loc, pc, xcp)
   P, objM(ps), h  (obj'M(ps), xs)  (stk, loc, pc, xcp)"

| bisim1CallParams:
  "P, ps, h  (ps', xs) [↔] (stk, loc, pc, xcp)
   P, objM(ps), h  (Val vM(ps'), xs)  (stk @ [v], loc, length (compE2 obj) +  pc, xcp)"

| bisim1CallThrowObj:
  "P, obj, h  (Throw a, xs)  (stk, loc, pc, a)
   P, objM(ps), h  (Throw a, xs)  (stk, loc, pc, a)"

| bisim1CallThrowParams:
  "P, ps, h  (map Val vs @ Throw a # ps', xs) [↔] (stk, loc, pc, a)
   P, objM(ps), h  (Throw a, xs)  (stk @ [v], loc, length (compE2 obj) + pc, a)"

| bisim1CallThrow:
  "length ps = length vs
   P, objM(ps), h  (Throw a, xs)  (vs @ [v], xs, length (compE2 obj) + length (compEs2 ps), a)"

| bisim1BlockSome1:
  "P, {V:T=v; e}, h  ({V:T=v; e}, xs)  ([], xs, 0, None)"

| bisim1BlockSome2:
  "P, {V:T=v; e}, h  ({V:T=v; e}, xs)  ([v], xs, Suc 0, None)"

| bisim1BlockSome4:
  "P, e, h  (e', xs)  (stk, loc, pc, xcp)
   P, {V:T=v; e}, h  ({V:T=None; e'}, xs)  (stk, loc, Suc (Suc pc), xcp)"

| bisim1BlockThrowSome:
  "P, e, h  (Throw a, xs)  (stk, loc, pc, a)
   P, {V:T=v; e}, h  (Throw a, xs)  (stk, loc, Suc (Suc pc), a)"

| bisim1BlockNone:
  "P, e, h  (e', xs)  (stk, loc, pc, xcp)
   P, {V:T=None; e}, h  ({V:T=None; e'}, xs)  (stk, loc, pc, xcp)"

| bisim1BlockThrowNone:
  "P, e, h  (Throw a, xs)  (stk, loc, pc, a)
    P, {V:T=None; e}, h  (Throw a, xs)  (stk, loc, pc, a)"


| bisim1Sync1:
  "P, e1, h  (e', xs)  (stk, loc, pc, xcp)
   P, syncV (e1) e2, h  (syncV (e') e2, xs)  (stk, loc, pc, xcp)"

| bisim1Sync2:
  "P, syncV (e1) e2, h  (syncV (Val v) e2, xs)  ([v, v], xs, Suc (length (compE2 e1)), None)"

| bisim1Sync3:
  "P, syncV (e1) e2, h  (syncV (Val v) e2, xs)  ([v], xs[V := v], Suc (Suc (length (compE2 e1))), None)"

| bisim1Sync4:
  "P, e2, h  (e', xs)  (stk, loc, pc, xcp)
   P, syncV (e1) e2, h  (insyncV (a) e', xs)  (stk, loc, Suc (Suc (Suc (length (compE2 e1) + pc))), xcp)"

| bisim1Sync5:
  "P, syncV (e1) e2, h  (insyncV (a) Val v, xs)  ([xs ! V, v], xs, 4 + length (compE2 e1) + length (compE2 e2), None)"

| bisim1Sync6:
  "P, syncV (e1) e2, h  (Val v, xs)  ([v], xs, 5 + length (compE2 e1) + length (compE2 e2), None)"

| bisim1Sync7:
  "P, syncV (e1) e2, h  (insyncV (a) Throw a', xs)  ([Addr a'], xs, 6 + length (compE2 e1) + length (compE2 e2), None)"

| bisim1Sync8:
  "P, syncV (e1) e2, h  (insyncV (a) Throw a', xs) 
                         ([xs ! V, Addr a'], xs, 7 + length (compE2 e1) + length (compE2 e2), None)"

| bisim1Sync9:
  "P, syncV (e1) e2, h  (Throw a, xs)  ([Addr a], xs, 8 + length (compE2 e1) + length (compE2 e2), None)"

| bisim1Sync10:
  "P, syncV (e1) e2, h  (Throw a, xs)  ([Addr a], xs, 8 + length (compE2 e1) + length (compE2 e2), a)"

| bisim1Sync11:
  "P, syncV (e1) e2, h  (THROW NullPointer, xs)  ([Null], xs, Suc (Suc (length (compE2 e1))), addr_of_sys_xcpt NullPointer)"

| bisim1Sync12:
  "P, syncV (e1) e2, h  (Throw a, xs)  ([v, v'], xs, 4 + length (compE2 e1) + length (compE2 e2), a)"

| bisim1Sync14:
  "P, syncV (e1) e2, h  (Throw a, xs) 
        ([v, Addr a'], xs, 7 + length (compE2 e1) + length (compE2 e2), a)"

| bisim1SyncThrow:
  "P, e1, h  (Throw a, xs)  (stk, loc, pc, a)
   P, syncV (e1) e2, h  (Throw a, xs)  (stk, loc, pc, a)"


| bisim1InSync: ― ‹This rule only exists such that @{text "P,e,h ⊢ (e, xs) ↔ ([], xs, 0, None)"} holds for all @{text "e"} 
  "P, insyncV (a) e, h  (insyncV (a) e, xs)  ([], xs, 0, None)"


| bisim1Seq1:
  "P, e1, h  (e', xs)  (stk, loc, pc, xcp)  P, e1;;e2, h  (e';;e2, xs)  (stk, loc, pc, xcp)"

| bisim1SeqThrow1:
  "P, e1, h  (Throw a, xs)  (stk, loc, pc, a)  P, e1;;e2, h  (Throw a, xs)  (stk, loc, pc, a)"

| bisim1Seq2:
  "P, e2, h  exs  (stk, loc, pc, xcp)
   P, e1;;e2, h  exs  (stk, loc, Suc (length (compE2 e1) + pc), xcp)"


| bisim1Cond1:
  "P, e, h  (e', xs)  (stk, loc, pc, xcp)
   P, if (e) e1 else e2, h  (if (e') e1 else e2, xs)  (stk, loc, pc, xcp)"

| bisim1CondThen:
  "P, e1, h  exs  (stk, loc, pc, xcp)
   P, if (e) e1 else e2, h  exs  (stk, loc, Suc (length (compE2 e) + pc), xcp)"

| bisim1CondElse:
  "P, e2, h  exs  (stk, loc, pc, xcp)
   P, if (e) e1 else e2, h  exs  (stk, loc, Suc (Suc (length (compE2 e) + length (compE2 e1) +  pc)), xcp)"

| bisim1CondThrow:
  "P, e, h  (Throw a, xs)  (stk, loc, pc, a)
   P, if (e) e1 else e2, h  (Throw a, xs)  (stk, loc, pc, a)"


| bisim1While1:
  "P, while (c) e, h  (while (c) e, xs)  ([], xs, 0, None)"

| bisim1While3:
  "P, c, h  (e', xs)  (stk, loc, pc, xcp)
   P, while (c) e, h  (if (e') (e;; while (c) e) else unit, xs)  (stk, loc, pc, xcp)"

| bisim1While4:
  "P, e, h  (e', xs)  (stk, loc, pc, xcp)
   P, while (c) e, h   (e';; while (c) e, xs)  (stk, loc, Suc (length (compE2 c) + pc), xcp)"

| bisim1While6:
  "P, while (c) e, h  (while (c) e, xs)  ([], xs, Suc (Suc (length (compE2 c) + length (compE2 e))), None)"

| bisim1While7:
  "P, while (c) e, h  (unit, xs)  ([], xs, Suc (Suc (Suc (length (compE2 c) + length (compE2 e)))), None)"

| bisim1WhileThrow1:
  "P, c, h  (Throw a, xs)  (stk, loc, pc, a)
   P, while (c) e, h  (Throw a, xs)  (stk, loc, pc, a)"

| bisim1WhileThrow2:
  "P, e, h  (Throw a, xs)  (stk, loc, pc, a)
    P, while (c) e, h  (Throw a, xs)  (stk, loc, Suc (length (compE2 c) + pc), a)"


| bisim1Throw1:
  "P, e, h  (e', xs)  (stk, loc, pc, xcp)  P, throw e, h  (throw e', xs)  (stk, loc, pc, xcp)"

| bisim1Throw2:
  "P, throw e, h  (Throw a, xs)  ([Addr a], xs, length (compE2 e), a)"

| bisim1ThrowNull:
  "P, throw e, h  (THROW NullPointer, xs)  ([Null], xs, length (compE2 e), addr_of_sys_xcpt NullPointer)"

| bisim1ThrowThrow:
  "P, e, h  (Throw a, xs)  (stk, loc, pc, a)  P, throw e, h  (Throw a, xs)  (stk, loc, pc, a)"


| bisim1Try:
  "P, e, h  (e', xs)  (stk, loc, pc, xcp)
    P, try e catch(C V) e2, h  (try e' catch(C V) e2, xs)  (stk, loc, pc, xcp)"

| bisim1TryCatch1:
  " P, e, h  (Throw a, xs)  (stk, loc, pc, a); typeof_addr h a = Class_type C'; P  C' * C 
   P, try e catch(C V) e2, h  ({V:Class C=None; e2}, xs[V := Addr a])  ([Addr a], loc, Suc (length (compE2 e)), None)"

| bisim1TryCatch2:
  "P, e2, h  (e', xs)  (stk, loc, pc, xcp)
    P, try e catch(C V) e2, h  ({V:Class C=None; e'}, xs)  (stk, loc, Suc (Suc (length (compE2 e) + pc)), xcp)"

| bisim1TryFail:
  " P, e, h  (Throw a, xs)  (stk, loc, pc, a); typeof_addr h a = Class_type C'; ¬ P  C' * C  
   P, try e catch(C V) e2, h  (Throw a, xs)  (stk, loc, pc, a)"

| bisim1TryCatchThrow:
  "P, e2, h  (Throw a, xs)  (stk, loc, pc, a)
    P, try e catch(C V) e2, h  (Throw a, xs)  (stk, loc, Suc (Suc (length (compE2 e) + pc)), a)"

| bisims1Nil: "P, [], h  ([], xs) [↔] ([], xs, 0, None)"

| bisims1List1:
  "P, e, h  (e', xs)  (stk, loc, pc, xcp)  P, e#es, h  (e'#es, xs) [↔] (stk, loc, pc, xcp)"

| bisims1List2:
  "P, es, h  (es', xs) [↔] (stk, loc, pc, xcp)
   P, e#es, h  (Val v # es', xs) [↔] (stk @ [v], loc, length (compE2 e) + pc, xcp)"


inductive_cases bisim1_cases:
  "P,e,h  (Val v, xs)  (stk, loc, pc, xcp)"


lemma bisim1_refl: "P,e,h  (e, xs)  ([], xs, 0, None)"
  and bisims1_refl: "P,es,h  (es, xs) [↔] ([], xs, 0, None)"
apply(induct e and es rule: call.induct calls.induct)
apply(auto intro: bisim1_bisims1.intros simp add: nat_fun_sum_eq_conv)
apply(rename_tac option a)
apply(case_tac option)
apply(auto intro: bisim1_bisims1.intros split: if_split_asm)
done

lemma bisims1_lengthD: "P, es, h  (es', xs) [↔] s  length es = length es'"
apply(induct es arbitrary: es' s)
apply(auto elim: bisims1.cases)
done

text ‹
  Derive an alternative induction rule for @{term bisim1} such that
  (i) induction hypothesis are generated for all subexpressions and
  (ii) the number of surrounding blocks is passed through.
›

inductive bisim1' :: 
  "'m prog  'heap  'addr expr1  nat  ('addr expr1 × 'addr locals1) 
   ('addr val list × 'addr val list × pc × 'addr option)  bool"

  and bisims1' :: 
  "'m prog  'heap  'addr expr1 list  nat  ('addr expr1 list × 'addr locals1)
   ('addr val list × 'addr val list × pc × 'addr option)  bool"

  and bisim1'_syntax :: 
  "'m prog  'addr expr1  nat  'heap  ('addr expr1 × 'addr locals1) 
   ('addr val list × 'addr val list × pc × 'addr option)  bool"
  ("_,_,_,_ ⊢'' _  _" [50, 0, 0, 0, 0, 50] 100)

  and bisims1'_syntax :: 
  "'m prog  'addr expr1 list  nat  'heap  ('addr expr1 list × 'addr val list) 
   ('addr val list × 'addr val list × pc × 'addr option)  bool"
  ("_,_,_,_ ⊢'' _ [↔] _" [50, 0, 0, 0, 0, 50] 100)
  for P :: "'m prog" and  h :: 'heap
where
  "P, e, n, h ⊢' exs  s  bisim1' P h e n exs s"
| "P, es, n, h ⊢' esxs [↔] s  bisims1' P h es n esxs s"

| bisim1Val2':
  "P, e, n, h ⊢' (Val v, xs)  (v # [], xs, length (compE2 e), None)"

| bisim1New':
  "P, new C, n, h ⊢' (new C, xs)  ([], xs, 0, None)"

| bisim1NewThrow':
  "P, new C, n, h ⊢' (THROW OutOfMemory, xs)  ([], xs, 0, addr_of_sys_xcpt OutOfMemory)"


| bisim1NewArray':
  "P, e, n, h ⊢' (e', xs)  (stk, loc, pc, xcp)
   P, newA Te, n, h ⊢' (newA Te', xs)  (stk, loc, pc, xcp)"

| bisim1NewArrayThrow':
  "P, e, n, h ⊢' (Throw a, xs)  (stk, loc, pc, a)
   P, newA Te, n, h ⊢' (Throw a, xs)  (stk, loc, pc, a)"

| bisim1NewArrayFail':
  "(xs. P, e, n, h ⊢' (e, xs)  ([], xs, 0, None))
   P, newA Te, n, h ⊢' (Throw a, xs)  ([v], xs, length (compE2 e), a)"


| bisim1Cast':
  "P, e, n, h ⊢' (e', xs)  (stk, loc, pc, xcp)
   P, Cast T e, n, h ⊢' (Cast T e', xs)  (stk, loc, pc, xcp)"

| bisim1CastThrow':
  "P, e, n, h ⊢' (Throw a, xs)  (stk, loc, pc, a)
   P, Cast T e, n, h ⊢' (Throw a, xs)  (stk, loc, pc, a)"

| bisim1CastFail':
  "(xs. P, e, n, h ⊢' (e, xs)  ([], xs, 0, None))
   P, Cast T e, n, h ⊢' (THROW ClassCast, xs)  ([v], xs, length (compE2 e), addr_of_sys_xcpt ClassCast)"


| bisim1InstanceOf':
  "P, e, n, h ⊢' (e', xs)  (stk, loc, pc, xcp)
   P, e instanceof T, n, h ⊢' (e' instanceof T, xs)  (stk, loc, pc, xcp)"

| bisim1InstanceOfThrow':
  "P, e, n, h ⊢' (Throw a, xs)  (stk, loc, pc, a)
   P, e instanceof T, n, h ⊢' (Throw a, xs)  (stk, loc, pc, a)"


| bisim1Val': "P, Val v, n, h ⊢' (Val v, xs)  ([], xs, 0, None)"

| bisim1Var': "P, Var V, n, h ⊢' (Var V, xs)  ([], xs, 0, None)"


| bisim1BinOp1':
  " P, e1, n, h ⊢' (e', xs)  (stk, loc, pc, xcp);
     xs. P, e2, n, h ⊢' (e2, xs)  ([], xs, 0, None) 
   P, e1«bop»e2, n, h ⊢' (e'«bop»e2, xs)  (stk, loc, pc, xcp)"

| bisim1BinOp2':
  " P, e2, n, h ⊢' (e', xs)  (stk, loc, pc, xcp);
     xs. P, e1, n, h ⊢' (e1, xs)  ([], xs, 0, None) 
   P, e1«bop»e2, n, h ⊢' (Val v1 «bop» e', xs)  (stk @ [v1], loc, length (compE2 e1) + pc, xcp)"

| bisim1BinOpThrow1':
  " P, e1, n, h ⊢' (Throw a, xs)  (stk, loc, pc, a);
     xs. P, e2, n, h ⊢' (e2, xs)  ([], xs, 0, None) 
   P, e1«bop»e2, n, h ⊢' (Throw a, xs)  (stk, loc, pc, a)"

| bisim1BinOpThrow2':
  " P, e2, n, h ⊢' (Throw a, xs)  (stk, loc, pc, a);
     xs. P, e1, n, h ⊢' (e1, xs)  ([], xs, 0, None) 
   P, e1«bop»e2, n, h ⊢' (Throw a, xs)  (stk @ [v1], loc, length (compE2 e1) + pc, a)"

| bisim1BinOpThrow':
  " xs. P, e1, n, h ⊢' (e1, xs)  ([], xs, 0, None); 
     xs. P, e2, n, h ⊢' (e2, xs)  ([], xs, 0, None) 
   P, e1«bop»e2, n, h ⊢' (Throw a, xs)  ([v1, v2], xs, length (compE2 e1) + length (compE2 e2), a)"

| bisim1LAss1':
  "P, e, n, h ⊢' (e', xs)  (stk, loc, pc, xcp)
   P, V:=e, n, h ⊢' (V:=e', xs)  (stk, loc, pc, xcp)"

| bisim1LAss2':
  "(xs. P, e, n, h ⊢' (e, xs)  ([], xs, 0, None))
    P, V:=e, n, h ⊢' (unit, xs)  ([], xs, Suc (length (compE2 e)), None)"

| bisim1LAssThrow':
  "P, e, n, h ⊢' (Throw a, xs)  (stk, loc, pc, a)
   P, V:=e, n, h ⊢' (Throw a, xs)  (stk, loc, pc, a)"


| bisim1AAcc1':
  " P, a, n, h ⊢' (a', xs)  (stk, loc, pc, xcp); xs. P, i, n, h ⊢' (i, xs)  ([], xs, 0, None) 
   P, ai, n, h ⊢' (a'i, xs)  (stk, loc, pc, xcp)"

| bisim1AAcc2':
  " P, i, n, h ⊢' (i', xs)  (stk, loc, pc, xcp); xs. P, a, n, h ⊢' (a, xs)  ([], xs, 0, None) 
   P, ai, n, h ⊢' (Val vi', xs)  (stk @ [v], loc, length (compE2 a) + pc, xcp)"

| bisim1AAccThrow1':
  " P, a, n, h ⊢' (Throw ad, xs)  (stk, loc, pc, ad);
     xs. P, i, n, h ⊢' (i, xs)  ([], xs, 0, None) 
   P, ai, n, h ⊢' (Throw ad, xs)  (stk, loc, pc, ad)"

| bisim1AAccThrow2':
  " P, i, n, h ⊢' (Throw ad, xs)  (stk, loc, pc, ad);
     xs. P, a, n, h ⊢' (a, xs)  ([], xs, 0, None) 
   P, ai, n, h ⊢' (Throw ad, xs)  (stk @ [v], loc, length (compE2 a) + pc, ad)"

| bisim1AAccFail':
  " xs. P, a, n, h ⊢' (a, xs)  ([], xs, 0, None); xs. P, i, n, h ⊢' (i, xs)  ([], xs, 0, None) 
   P, ai, n, h ⊢' (Throw ad, xs)  ([v, v'], xs, length (compE2 a) + length (compE2 i), ad)"


| bisim1AAss1':
  " P, a, n, h ⊢' (a', xs)  (stk, loc, pc, xcp); 
     xs. P, i, n, h ⊢' (i, xs)  ([], xs, 0, None);
     xs. P, e, n, h ⊢' (e, xs)  ([], xs, 0, None) 
   P, ai := e, n, h ⊢' (a'i := e, xs)  (stk, loc, pc, xcp)"

| bisim1AAss2':
  " P, i, n, h ⊢' (i', xs)  (stk, loc, pc, xcp);
     xs. P, a, n, h ⊢' (a, xs)  ([], xs, 0, None);
     xs. P, e, n, h ⊢' (e, xs)  ([], xs, 0, None) 
   P, ai := e, n, h ⊢' (Val vi' := e, xs)  (stk @ [v], loc, length (compE2 a) + pc, xcp)"

| bisim1AAss3':
  " P, e, n, h ⊢' (e', xs)  (stk, loc, pc, xcp); 
     xs. P, a, n, h ⊢' (a, xs)  ([], xs, 0, None);
     xs. P, i, n, h ⊢' (i, xs)  ([], xs, 0, None) 
   P, ai := e, n, h ⊢' (Val vVal v' := e', xs)  (stk @ [v', v], loc, length (compE2 a) + length (compE2 i) + pc, xcp)"

| bisim1AAssThrow1':
  " P, a, n, h ⊢' (Throw ad, xs)  (stk, loc, pc, ad);
     xs. P, i, n, h ⊢' (i, xs)  ([], xs, 0, None); 
     xs. P, e, n, h ⊢' (e, xs)  ([], xs, 0, None) 
   P, ai := e, n, h ⊢' (Throw ad, xs)  (stk, loc, pc, ad)"

| bisim1AAssThrow2':
  " P, i, n, h ⊢' (Throw ad, xs)  (stk, loc, pc, ad); 
     xs. P, a, n, h ⊢' (a, xs)  ([], xs, 0, None);
     xs. P, e, n, h ⊢' (e, xs)  ([], xs, 0, None) 
   P, ai := e, n, h ⊢' (Throw ad, xs)  (stk @ [v], loc, length (compE2 a) + pc, ad)"

| bisim1AAssThrow3':
  " P, e, n, h ⊢' (Throw ad, xs)  (stk, loc, pc, ad);
     xs. P, a, n, h ⊢' (a, xs)  ([], xs, 0, None); 
     xs. P, i, n, h ⊢' (i, xs)  ([], xs, 0, None) 
   P, ai := e, n, h ⊢' (Throw ad, xs)  (stk @ [v', v], loc, length (compE2 a) + length (compE2 i) + pc, ad)"

| bisim1AAssFail':
  " xs. P, a, n, h ⊢' (a, xs)  ([], xs, 0, None);  
     xs. P, i, n, h ⊢' (i, xs)  ([], xs, 0, None);
     xs. P, e, n, h ⊢' (e, xs)  ([], xs, 0, None) 
   P, ai := e, n, h ⊢' (Throw ad, xs)  ([v', v, v''], xs, length (compE2 a) + length (compE2 i) + length (compE2 e), ad)"

| bisim1AAss4':
  " xs. P, a, n, h ⊢' (a, xs)  ([], xs, 0, None);  
     xs. P, i, n, h ⊢' (i, xs)  ([], xs, 0, None);
     xs. P, e, n, h ⊢' (e, xs)  ([], xs, 0, None) 
   P, ai := e, n, h ⊢' (unit, xs)  ([], xs, Suc (length (compE2 a) + length (compE2 i) + length (compE2 e)), None)"


| bisim1ALength': 
  "P, a, n, h ⊢' (a', xs)  (stk, loc, pc, xcp)
   P, a∙length, n, h ⊢' (a'∙length, xs)  (stk, loc, pc, xcp)"

| bisim1ALengthThrow':
  "P, a, n, h ⊢' (Throw ad, xs)  (stk, loc, pc, ad)
   P, a∙length, n, h ⊢' (Throw ad, xs)  (stk, loc, pc, ad)"


| bisim1ALengthNull':
  "(xs. P, a, n, h ⊢' (a, xs)  ([], xs, 0, None))
   P, a∙length, n, h ⊢' (THROW NullPointer, xs)  ([Null], xs, length (compE2 a), addr_of_sys_xcpt NullPointer)"


| bisim1FAcc': 
  "P, e, n, h ⊢' (e', xs)  (stk, loc, pc, xcp)
   P, eF{D}, n, h ⊢' (e'F{D}, xs)  (stk, loc, pc, xcp)"

| bisim1FAccThrow':
  "P, e, n, h ⊢' (Throw ad, xs)  (stk, loc, pc, ad)
   P, eF{D}, n, h ⊢' (Throw ad, xs)  (stk, loc, pc, ad)"

| bisim1FAccNull':
  "(xs. P, e, n, h ⊢' (e, xs)  ([], xs, 0, None))
    P, eF{D}, n, h ⊢' (THROW NullPointer, xs)  ([Null], xs, length (compE2 e), addr_of_sys_xcpt NullPointer)"


| bisim1FAss1': 
  " P, e, n, h ⊢' (e', xs)  (stk, loc, pc, xcp); 
     xs. P, e2, n, h ⊢' (e2, xs)  ([], xs, 0, None) 
   P, eF{D} := e2, n, h ⊢' (e'F{D} := e2, xs)  (stk, loc, pc, xcp)"

| bisim1FAss2': 
  " P, e2, n, h ⊢' (e', xs)  (stk, loc, pc, xcp);
     xs. P, e, n, h ⊢' (e, xs)  ([], xs, 0, None) 
   P, eF{D} := e2, n, h ⊢' (Val vF{D} := e', xs)  (stk @ [v], loc, length (compE2 e) + pc, xcp)"

| bisim1FAssThrow1':
  " P, e, n, h ⊢' (Throw ad, xs)  (stk, loc, pc, ad);
     xs. P, e2, n, h ⊢' (e2, xs)  ([], xs, 0, None) 
   P, eF{D} := e2, n, h ⊢' (Throw ad, xs)  (stk, loc, pc, ad)"

| bisim1FAssThrow2':
  " P, e2, n, h ⊢' (Throw ad, xs)  (stk, loc, pc, ad);
     xs. P, e, n, h ⊢' (e, xs)  ([], xs, 0, None) 
   P, eF{D} := e2, n, h ⊢' (Throw ad, xs)  (stk @ [v], loc, length (compE2 e) + pc, ad)"

| bisim1FAssNull':
  " xs. P, e, n, h ⊢' (e, xs)  ([], xs, 0, None);
     xs. P, e2, n, h ⊢' (e2, xs)  ([], xs, 0, None) 
    P, eF{D} := e2, n, h ⊢' (THROW NullPointer, xs)  ([v, Null], xs, length (compE2 e) + length (compE2 e2), addr_of_sys_xcpt NullPointer)"

| bisim1FAss3':
  " xs. P, e, n, h ⊢' (e, xs)  ([], xs, 0, None); 
     xs. P, e2, n, h ⊢' (e2, xs)  ([], xs, 0, None) 
    P, eF{D} := e2, n, h ⊢' (unit, xs)  ([], xs, Suc (length (compE2 e) + length (compE2 e2)), None)"


| bisim1CAS1':
  " P, e1, n, h ⊢' (e1', xs)  (stk, loc, pc, xcp); 
    xs. P, e2, n, h ⊢' (e2, xs)  ([], xs, 0, None);
    xs. P, e3, n, h ⊢' (e3, xs)  ([], xs, 0, None) 
   P, e1∙compareAndSwap(DF, e2, e3), n, h ⊢' (e1'∙compareAndSwap(DF, e2, e3), xs)  (stk, loc, pc, xcp)"

| bisim1CAS2':
  " P, e2, n, h ⊢' (e2', xs)  (stk, loc, pc, xcp); 
    xs. P, e1, n, h ⊢' (e1, xs)  ([], xs, 0, None);
    xs. P, e3, n, h ⊢' (e3, xs)  ([], xs, 0, None) 
   P, e1∙compareAndSwap(DF, e2, e3), n, h ⊢' (Val v∙compareAndSwap(DF, e2', e3), xs)  (stk @ [v], loc, length (compE2 e1) + pc, xcp)"

| bisim1CAS3':
  " P, e3, n, h ⊢' (e3', xs)  (stk, loc, pc, xcp);
    xs. P, e1, n, h ⊢' (e1, xs)  ([], xs, 0, None);
    xs. P, e2, n, h ⊢' (e2, xs)  ([], xs, 0, None) 
   P, e1∙compareAndSwap(DF, e2, e3), n, h ⊢' (Val v∙compareAndSwap(DF, Val v', e3'), xs)  (stk @ [v', v], loc, length (compE2 e1) + length (compE2 e2) + pc, xcp)"

| bisim1CASThrow1':
  " P, e1, n, h ⊢' (Throw ad, xs)  (stk, loc, pc, ad);
    xs. P, e2, n, h ⊢' (e2, xs)  ([], xs, 0, None);
    xs. P, e3, n, h ⊢' (e3, xs)  ([], xs, 0, None) 
   P, e1∙compareAndSwap(DF, e2, e3), n, h ⊢' (Throw ad, xs)  (stk, loc, pc, ad)"

| bisim1CASThrow2':
  " P, e2, n, h ⊢' (Throw ad, xs)  (stk, loc, pc, ad);
    xs. P, e1, n, h ⊢' (e1, xs)  ([], xs, 0, None);
    xs. P, e3, n, h ⊢' (e3, xs)  ([], xs, 0, None) 
   P, e1∙compareAndSwap(DF, e2, e3), n, h ⊢' (Throw ad, xs)  (stk @ [v], loc, length (compE2 e1) + pc, ad)"

| bisim1CASThrow3':
  " P, e3, n, h ⊢' (Throw ad, xs)  (stk, loc, pc, ad);
    xs. P, e1, n, h ⊢' (e1, xs)  ([], xs, 0, None);
    xs. P, e2, n, h ⊢' (e2, xs)  ([], xs, 0, None) 
   P, e1∙compareAndSwap(DF, e2, e3), n, h ⊢' (Throw ad, xs)  (stk @ [v', v], loc, length (compE2 e1) + length (compE2 e2) + pc, ad)"

| bisim1CASFail':
  " xs. P, e1, n, h ⊢' (e1, xs)  ([], xs, 0, None);
    xs. P, e2, n, h ⊢' (e2, xs)  ([], xs, 0, None); 
    xs. P, e3, n, h ⊢' (e3, xs)  ([], xs, 0, None) 
   P, e1∙compareAndSwap(DF, e2, e3), n, h ⊢' (Throw ad, xs)  ([v', v, v''], xs, length (compE2 e1) + length (compE2 e2) + length (compE2 e3), ad)"


| bisim1Call1':
  " P, obj, n, h ⊢' (obj', xs)  (stk, loc, pc, xcp);
     xs. P, ps, n, h ⊢' (ps, xs) [↔] ([], xs, 0, None) 
   P, objM(ps), n, h ⊢' (obj'M(ps), xs)  (stk, loc, pc, xcp)"

| bisim1CallParams':
  " P, ps, n, h ⊢' (ps', xs) [↔] (stk, loc, pc, xcp); ps  [];
     xs. P, obj, n, h ⊢' (obj, xs)  ([], xs, 0, None) 
   P, objM(ps), n, h ⊢' (Val vM(ps'), xs)  (stk @ [v], loc, length (compE2 obj) +  pc, xcp)"

| bisim1CallThrowObj':
  " P, obj, n, h ⊢' (Throw a, xs)  (stk, loc, pc, a);
     xs. P, ps, n, h ⊢' (ps, xs) [↔] ([], xs, 0, None)
   P, objM(ps), n, h ⊢' (Throw a, xs)  (stk, loc, pc, a)"

| bisim1CallThrowParams':
  " P, ps, n, h ⊢' (map Val vs @ Throw a # ps', xs) [↔] (stk, loc, pc, a);
     xs. P, obj, n, h ⊢' (obj, xs)  ([], xs, 0, None) 
   P, objM(ps), n, h ⊢' (Throw a, xs)  (stk @ [v], loc, length (compE2 obj) + pc, a)"

| bisim1CallThrow':
  " length ps = length vs;
     xs. P, obj, n, h ⊢' (obj, xs)  ([], xs, 0, None); xs. P, ps, n, h ⊢' (ps, xs) [↔] ([], xs, 0, None) 
   P, objM(ps), n, h ⊢' (Throw a, xs)  (vs @ [v], xs, length (compE2 obj) + length (compEs2 ps), a)"

| bisim1BlockSome1':
  "(xs. P, e, Suc n, h ⊢' (e, xs)  ([], xs, 0, None))
   P, {V:T=v; e}, n, h ⊢' ({V:T=v; e}, xs)  ([], xs, 0, None)"

| bisim1BlockSome2':
  "(xs. P, e, Suc n, h ⊢' (e, xs)  ([], xs, 0, None))
   P, {V:T=v; e}, n, h ⊢' ({V:T=v; e}, xs)  ([v], xs, Suc 0, None)"

| bisim1BlockSome4':
  "P, e, Suc n, h ⊢' (e', xs)  (stk, loc, pc, xcp)
   P, {V:T=v; e}, n, h ⊢' ({V:T=None; e'}, xs)  (stk, loc, Suc (Suc pc), xcp)"

| bisim1BlockThrowSome':
  "P, e, Suc n, h ⊢' (Throw a, xs)  (stk, loc, pc, a)
   P, {V:T=v; e}, n, h ⊢' (Throw a, xs)  (stk, loc, Suc (Suc pc), a)"

| bisim1BlockNone':
  "P, e, Suc n, h ⊢' (e', xs)  (stk, loc, pc, xcp)
   P, {V:T=None; e}, n, h ⊢' ({V:T=None; e'}, xs)  (stk, loc, pc, xcp)"

| bisim1BlockThrowNone':
  "P, e, Suc n, h ⊢' (Throw a, xs)  (stk, loc, pc, a)
   P, {V:T=None; e}, n, h ⊢' (Throw a, xs)  (stk, loc, pc, a)"


| bisim1Sync1':
  " P, e1, n, h ⊢' (e', xs)  (stk, loc, pc, xcp); 
     xs. P, e2, Suc n, h ⊢' (e2, xs)  ([], xs, 0, None) 
   P, syncV (e1) e2, n, h ⊢' (syncV (e') e2, xs)  (stk, loc, pc, xcp)"

| bisim1Sync2':
  " xs. P, e1, n, h ⊢' (e1, xs)  ([], xs, 0, None);
    xs. P, e2, Suc n, h ⊢' (e2, xs)  ([], xs, 0, None) 
   P, syncV (e1) e2, n, h ⊢' (syncV (Val v) e2, xs)  ([v, v], xs, Suc (length (compE2 e1)), None)"

| bisim1Sync3':
  " xs. P, e1, n, h ⊢' (e1, xs)  ([], xs, 0, None);
    xs. P, e2, Suc n, h ⊢' (e2, xs)  ([], xs, 0, None) 
   P, syncV (e1) e2, n, h ⊢' (syncV (Val v) e2, xs)  ([v], xs[V := v], Suc (Suc (length (compE2 e1))), None)"

| bisim1Sync4':
  " P, e2, Suc n, h ⊢' (e', xs)  (stk, loc, pc, xcp); 
     xs. P, e1, n, h ⊢' (e1, xs)  ([], xs, 0, None) 
   P, syncV (e1) e2, n, h ⊢' (insyncV (a) e', xs)  (stk, loc, Suc (Suc (Suc (length (compE2 e1) + pc))), xcp)"

| bisim1Sync5':
  " xs. P, e1, n, h ⊢' (e1, xs)  ([], xs, 0, None);
    xs. P, e2, Suc n, h ⊢' (e2, xs)  ([], xs, 0, None) 
   P, syncV (e1) e2, n, h ⊢' (insyncV (a) Val v, xs)  ([xs ! V, v], xs, 4 + length (compE2 e1) + length (compE2 e2), None)"

| bisim1Sync6':
  " xs. P, e1, n, h ⊢' (e1, xs)  ([], xs, 0, None);
    xs. P, e2, Suc n, h ⊢' (e2, xs)  ([], xs, 0, None) 
   P, syncV (e1) e2, n, h ⊢' (Val v, xs)  ([v], xs, 5 + length (compE2 e1) + length (compE2 e2), None)"

| bisim1Sync7':
  " xs. P, e1, n, h ⊢' (e1, xs)  ([], xs, 0, None);
    xs. P, e2, Suc n, h ⊢' (e2, xs)  ([], xs, 0, None) 
   P, syncV (e1) e2, n, h ⊢' (insyncV (a) Throw a', xs)  ([Addr a'], xs, 6 + length (compE2 e1) + length (compE2 e2), None)"

| bisim1Sync8':
  " xs. P, e1, n, h ⊢' (e1, xs)  ([], xs, 0, None);
    xs. P, e2, Suc n, h ⊢' (e2, xs)  ([], xs, 0, None) 
   P, syncV (e1) e2, n, h ⊢' (insyncV (a) Throw a', xs) 
        ([xs ! V, Addr a'], xs, 7 + length (compE2 e1) + length (compE2 e2), None)"

| bisim1Sync9':
  " xs. P, e1, n, h ⊢' (e1, xs)  ([], xs, 0, None);
    xs. P, e2, Suc n, h ⊢' (e2, xs)  ([], xs, 0, None) 
   P, syncV (e1) e2, n, h ⊢' (Throw a, xs)  ([Addr a], xs, 8 + length (compE2 e1) + length (compE2 e2), None)"

| bisim1Sync10':
  " xs. P, e1, n, h ⊢' (e1, xs)  ([], xs, 0, None);
    xs. P, e2, Suc n, h ⊢' (e2, xs)  ([], xs, 0, None) 
   P, syncV (e1) e2, n, h ⊢' (Throw a, xs)  ([Addr a], xs, 8 + length (compE2 e1) + length (compE2 e2), a)"

| bisim1Sync11':
  " xs. P, e1, n, h ⊢' (e1, xs)  ([], xs, 0, None);
    xs. P, e2, Suc n, h ⊢' (e2, xs)  ([], xs, 0, None) 
   P, syncV (e1) e2, n, h ⊢' (THROW NullPointer, xs)  ([Null], xs, Suc (Suc (length (compE2 e1))), addr_of_sys_xcpt NullPointer)"

| bisim1Sync12':
  " xs. P, e1, n, h ⊢' (e1, xs)  ([], xs, 0, None);
    xs. P, e2, Suc n, h ⊢' (e2, xs)  ([], xs, 0, None) 
   P, syncV (e1) e2, n, h ⊢' (Throw a, xs)  ([v, v'], xs, 4 + length (compE2 e1) + length (compE2 e2), a)"

| bisim1Sync14':
  " xs. P, e1, n, h ⊢' (e1, xs)  ([], xs, 0, None);
    xs. P, e2, Suc n, h ⊢' (e2, xs)  ([], xs, 0, None) 
   P, syncV (e1) e2, n, h ⊢' (Throw a, xs) 
        ([v, Addr a'], xs, 7 + length (compE2 e1) + length (compE2 e2), a)"

| bisim1SyncThrow':
  " P, e1, n, h ⊢' (Throw a, xs)  (stk, loc, pc, a); 
    xs. P, e2, Suc n, h ⊢' (e2, xs)  ([], xs, 0, None) 
   P, syncV (e1) e2, n, h ⊢' (Throw a, xs)  (stk, loc, pc, a)"


| bisim1InSync':
  "P, insyncV (a) e, n, h ⊢' (insyncV (a) e, xs)  ([], xs, 0, None)"


| bisim1Seq1':
  " P, e1, n, h ⊢' (e', xs)  (stk, loc, pc, xcp);
     xs. P, e2, n, h ⊢' (e2, xs)  ([], xs, 0, None) 
    P, e1;;e2, n, h ⊢' (e';;e2, xs)  (stk, loc, pc, xcp)"

| bisim1SeqThrow1':
  " P, e1, n, h ⊢' (Throw a, xs)  (stk, loc, pc, a);
     xs. P, e2, n, h ⊢' (e2, xs)  ([], xs, 0, None) 
    P, e1;;e2, n, h ⊢' (Throw a, xs)  (stk, loc, pc, a)"

| bisim1Seq2':
  " P, e2, n, h ⊢' (e', xs)  (stk, loc, pc, xcp);
     xs. P, e1, n, h ⊢' (e1, xs)  ([], xs, 0, None) 
   P, e1;;e2, n, h ⊢' (e', xs)  (stk, loc, Suc (length (compE2 e1) + pc), xcp)"


| bisim1Cond1':
  " P, e, n, h ⊢' (e', xs)  (stk, loc, pc, xcp);
     xs. P, e1, n, h ⊢' (e1, xs)  ([], xs, 0, None);
     xs. P, e2, n, h ⊢' (e2, xs)  ([], xs, 0, None) 
   P, if (e) e1 else e2, n, h ⊢' (if (e') e1 else e2, xs)  (stk, loc, pc, xcp)"

| bisim1CondThen':
  " P, e1, n, h ⊢' (e', xs)  (stk, loc, pc, xcp);
     xs. P, e, n, h ⊢' (e, xs)  ([], xs, 0, None);
     xs. P, e2, n, h ⊢' (e2, xs)  ([], xs, 0, None) 
   P, if (e) e1 else e2, n, h ⊢' (e', xs)  (stk, loc, Suc (length (compE2 e) + pc), xcp)"

| bisim1CondElse':
  " P, e2, n, h ⊢' (e', xs)  (stk, loc, pc, xcp);
     xs. P, e, n, h ⊢' (e, xs)  ([], xs, 0, None);
     xs. P, e1, n, h ⊢' (e1, xs)  ([], xs, 0, None) 
   P, if (e) e1 else e2, n, h ⊢' (e', xs)  (stk, loc, Suc (Suc (length (compE2 e) + length (compE2 e1) +  pc)), xcp)"

| bisim1CondThrow':
  " P, e, n, h ⊢' (Throw a, xs)  (stk, loc, pc, a);
     xs. P, e1, n, h ⊢' (e1, xs)  ([], xs, 0, None);
     xs. P, e2, n, h ⊢' (e2, xs)  ([], xs, 0, None) 
   P, if (e) e1 else e2, n, h ⊢' (Throw a, xs)  (stk, loc, pc, a)"


| bisim1While1':
  " xs. P, c, n, h ⊢' (c, xs)  ([], xs, 0, None);
     xs. P, e, n, h ⊢' (e, xs)  ([], xs, 0, None) 
   P, while (c) e, n, h ⊢' (while (c) e, xs)  ([], xs, 0, None)"

| bisim1While3':
  " P, c, n, h ⊢' (e', xs)  (stk, loc, pc, xcp);
     xs. P, e, n, h ⊢' (e, xs)  ([], xs, 0, None) 
   P, while (c) e, n, h ⊢' (if (e') (e;; while (c) e) else unit, xs)  (stk, loc, pc, xcp)"

| bisim1While4':
  " P, e, n, h ⊢' (e', xs)  (stk, loc, pc, xcp);
     xs. P, c, n, h ⊢' (c, xs)  ([], xs, 0, None) 
   P, while (c) e, n, h  ⊢' (e';; while (c) e, xs)  (stk, loc, Suc (length (compE2 c) + pc), xcp)"

| bisim1While6':
  " xs. P, c, n, h ⊢' (c, xs)  ([], xs, 0, None);
     xs. P, e, n, h ⊢' (e, xs)  ([], xs, 0, None)   
  P, while (c) e, n, h ⊢' (while (c) e, xs)  ([], xs, Suc (Suc (length (compE2 c) + length (compE2 e))), None)"

| bisim1While7':
  " xs. P, c, n, h ⊢' (c, xs)  ([], xs, 0, None);
     xs. P, e, n, h ⊢' (e, xs)  ([], xs, 0, None)   
  P, while (c) e, n, h ⊢' (unit, xs)  ([], xs, Suc (Suc (Suc (length (compE2 c) + length (compE2 e)))), None)"

| bisim1WhileThrow1':
  " P, c, n, h ⊢' (Throw a, xs)  (stk, loc, pc, a);
     xs. P, e, n, h ⊢' (e, xs)  ([], xs, 0, None) 
   P, while (c) e, n, h ⊢' (Throw a, xs)  (stk, loc, pc, a)"

| bisim1WhileThrow2':
  " P, e, n, h ⊢' (Throw a, xs)  (stk, loc, pc, a); 
     xs. P, c, n, h ⊢' (c, xs)  ([], xs, 0, None) 
    P, while (c) e, n, h ⊢' (Throw a, xs)  (stk, loc, Suc (length (compE2 c) + pc), a)"


| bisim1Throw1':
  "P, e, n, h ⊢' (e', xs)  (stk, loc, pc, xcp)
   P, throw e, n, h ⊢' (throw e', xs)  (stk, loc, pc, xcp)"

| bisim1Throw2':
  "(xs. P, e, n, h ⊢' (e, xs)  ([], xs, 0, None))
   P, throw e, n, h ⊢' (Throw a, xs)  ([Addr a], xs, length (compE2 e), a)"

| bisim1ThrowNull':
  "(xs. P, e, n, h ⊢' (e, xs)  ([], xs, 0, None))
   P, throw e, n, h ⊢' (THROW NullPointer, xs)  ([Null], xs, length (compE2 e), addr_of_sys_xcpt NullPointer)"

| bisim1ThrowThrow':
  "P, e, n, h ⊢' (Throw a, xs)  (stk, loc, pc, a)
   P, throw e, n, h ⊢' (Throw a, xs)  (stk, loc, pc, a)"


| bisim1Try':
  " P, e, n, h ⊢' (e', xs)  (stk, loc, pc, xcp);
     xs. P, e2, Suc n, h ⊢' (e2, xs)  ([], xs, 0, None) 
    P, try e catch(C V) e2, n, h ⊢' (try e' catch(C V) e2, xs)  (stk, loc, pc, xcp)"

| bisim1TryCatch1':
  " P, e, n, h ⊢' (Throw a, xs)  (stk, loc, pc, a); typeof_addr h a = Class_type C'; P  C' * C;
     xs. P, e2, Suc n, h ⊢' (e2, xs)  ([], xs, 0, None) 
   P, try e catch(C V) e2, n, h ⊢' ({V:Class C=None; e2}, xs[V := Addr a])  ([Addr a], loc, Suc (length (compE2 e)), None)"

| bisim1TryCatch2':
  " P, e2, Suc n, h ⊢' (e', xs)  (stk, loc, pc, xcp);
     xs. P, e, n, h ⊢' (e, xs)  ([], xs, 0, None) 
    P, try e catch(C V) e2, n, h ⊢' ({V:Class C=None; e'}, xs)  (stk, loc, Suc (Suc (length (compE2 e) + pc)), xcp)"

| bisim1TryFail':
  " P, e, n, h ⊢' (Throw a, xs)  (stk, loc, pc, a); typeof_addr h a = Class_type C'; ¬ P  C' * C;
     xs. P, e2, Suc n, h ⊢' (e2, xs)  ([], xs, 0, None)  
   P, try e catch(C V) e2, n, h ⊢' (Throw a, xs)  (stk, loc, pc, a)"

| bisim1TryCatchThrow':
  " P, e2, Suc n, h ⊢' (Throw a, xs)  (stk, loc, pc, a);
     xs. P, e, n, h ⊢' (e, xs)  ([], xs, 0, None) 
    P, try e catch(C V) e2, n, h ⊢' (Throw a, xs)  (stk, loc, Suc (Suc (length (compE2 e) + pc)), a)"

| bisims1Nil': "P, [], n, h ⊢' ([], xs) [↔] ([], xs, 0, None)"

| bisims1List1':
  " P, e, n, h ⊢' (e', xs)  (stk, loc, pc, xcp);
     xs. P, es, n, h ⊢' (es, xs) [↔] ([], xs, 0, None) 
   P, e#es, n, h ⊢' (e'#es, xs) [↔] (stk, loc, pc, xcp)"

| bisims1List2':
  " P, es, n, h ⊢' (es', xs) [↔] (stk, loc, pc, xcp);
     xs. P, e, n, h ⊢' (e, xs)  ([], xs, 0, None) 
   P, e#es, n, h ⊢' (Val v # es', xs) [↔] (stk @ [v], loc, length (compE2 e) + pc, xcp)"

lemma bisim1'_refl: "P,e,n,h ⊢' (e,xs)  ([],xs,0,None)"
  and bisims1'_refl: "P,es,n,h ⊢' (es,xs) [↔] ([],xs,0,None)"
apply(induct e and es arbitrary: n xs and n xs rule: call.induct calls.induct)
apply(auto intro: bisim1'_bisims1'.intros simp add: nat_fun_sum_eq_conv)
apply(rename_tac option a b c)
apply(case_tac option)
apply(auto intro: bisim1'_bisims1'.intros simp add: fun_eq_iff split: if_split_asm)
done

lemma bisim1_imp_bisim1': "P, e, h  exs  s  P, e, n, h ⊢' exs  s"
  and bisims1_imp_bisims1': "P, es, h  esxs [↔] s  P, es, n, h ⊢' esxs [↔] s"
proof(induct arbitrary: n and n rule: bisim1_bisims1.inducts)
  case (bisim1CallParams ps ps' xs stk loc pc xcp obj M v)
  show ?case
  proof(cases "ps = []")
    case True
    with P,ps,h  (ps', xs) [↔] (stk, loc, pc, xcp) have "ps' = []" "pc = 0" "stk = []" "loc = xs" "xcp = None"
      by(auto elim: bisims1.cases)
    moreover have "P,obj,n,h ⊢' (Val v,xs)  ([v],xs,length (compE2 obj),None)"
      by(blast intro: bisim1Val2' bisim1'_refl)
    hence "P,objM([]),n,h ⊢' (Val vM([]),xs)  ([v],xs,length (compE2 obj),None)"
      by-(rule bisim1Call1', auto intro!: bisims1Nil' simp add: bsoks_def)
    ultimately show ?thesis using True by simp
  next
    case False with bisim1CallParams show ?thesis
      by(auto intro: bisim1CallParams' bisims1'_refl bisim1'_refl)
  qed
qed(auto intro: bisim1'_bisims1'.intros bisim1'_refl bisims1'_refl)

lemma bisim1'_imp_bisim1: "P, e, n, h ⊢' exs  s  P, e, h  exs  s"
  and bisims1'_imp_bisims1: "P, es, n, h ⊢' esxs [↔] s  P, es, h  esxs [↔] s"
apply(induct rule: bisim1'_bisims1'.inducts)
apply(blast intro: bisim1_bisims1.intros)+
done

lemma bisim1'_eq_bisim1: "bisim1' P h e n = bisim1 P h e"
  and bisims1'_eq_bisims1: "bisims1' P h es n = bisims1 P h es"
by(blast intro!: ext bisim1_imp_bisim1' bisims1_imp_bisims1' bisim1'_imp_bisim1 bisims1'_imp_bisims1)+

end

(* FIXME: Take lemmas out of locale to speed up opening the context *)

lemmas bisim1_bisims1_inducts = 
  J1_JVM_heap_base.bisim1'_bisims1'.inducts
  [simplified J1_JVM_heap_base.bisim1'_eq_bisim1 J1_JVM_heap_base.bisims1'_eq_bisims1, 
  consumes 1,
  case_names bisim1Val2 bisim1New bisim1NewThrow
  bisim1NewArray bisim1NewArrayThrow bisim1NewArrayFail bisim1Cast bisim1CastThrow bisim1CastFail
  bisim1InstanceOf bisim1InstanceOfThrow
  bisim1Val bisim1Var bisim1BinOp1 bisim1BinOp2 bisim1BinOpThrow1 bisim1BinOpThrow2 bisim1BinOpThrow
  bisim1LAss1 bisim1LAss2 bisim1LAssThrow
  bisim1AAcc1 bisim1AAcc2 bisim1AAccThrow1 bisim1AAccThrow2 bisim1AAccFail
  bisim1AAss1 bisim1AAss2 bisim1AAss3 bisim1AAssThrow1 bisim1AAssThrow2
  bisim1AAssThrow3 bisim1AAssFail bisim1AAss4
  bisim1ALength bisim1ALengthThrow bisim1ALengthNull
  bisim1FAcc bisim1FAccThrow bisim1FAccNull
  bisim1FAss1 bisim1FAss2 bisim1FAssThrow1 bisim1FAssThrow2 bisim1FAssNull bisim1FAss3
  bisim1CAS1 bisim1CAS2 bisim1CAS3 bisim1CASThrow1 bisim1CASThrow2
  bisim1CASThrow3 bisim1CASFail
  bisim1Call1 bisim1CallParams bisim1CallThrowObj bisim1CallThrowParams
  bisim1CallThrow
  bisim1BlockSome1 bisim1BlockSome2 bisim1BlockSome4 bisim1BlockThrowSome
  bisim1BlockNone bisim1BlockThrowNone
  bisim1Sync1 bisim1Sync2 bisim1Sync3 bisim1Sync4 bisim1Sync5 bisim1Sync6
  bisim1Sync7 bisim1Sync8 bisim1Sync9 bisim1Sync10 bisim1Sync11 bisim1Sync12
  bisim1Sync14 bisim1SyncThrow bisim1InSync
  bisim1Seq1 bisim1SeqThrow1 bisim1Seq2
  bisim1Cond1 bisim1CondThen bisim1CondElse bisim1CondThrow
  bisim1While1 bisim1While3 bisim1While4
  bisim1While6 bisim1While7 bisim1WhileThrow1 bisim1WhileThrow2
  bisim1Throw1 bisim1Throw2 bisim1ThrowNull bisim1ThrowThrow
  bisim1Try bisim1TryCatch1 bisim1TryCatch2 bisim1TryFail bisim1TryCatchThrow
  bisims1Nil bisims1List1 bisims1List2]

lemmas bisim1_bisims1_inducts_split = bisim1_bisims1_inducts[split_format (complete)]

context J1_JVM_heap_base begin

lemma bisim1_pc_length_compE2: "P,E,h  (e, xs)  (stk, loc, pc, xcp)  pc  length (compE2 E)"
  and bisims1_pc_length_compEs2: "P,Es,h  (es, xs) [↔] (stk, loc, pc, xcp)  pc  length (compEs2 Es)"
apply(induct "(stk, loc, pc, xcp)" and "(stk, loc, pc, xcp)" 
  arbitrary: stk loc pc xcp and stk loc pc xcp rule: bisim1_bisims1.inducts)
apply(auto)
done

lemma bisim1_pc_length_compE2D:
  "P,e,h  (e', xs)  (stk,loc,length (compE2 e),xcp)
   xcp = None  call1 e' = None  (v. stk = [v]  (is_val e'  e' = Val v  xs = loc))"

  and bisims1_pc_length_compEs2D:
  "P,es,h  (es', xs) [↔] (stk,loc,length (compEs2 es),xcp)
   xcp = None  calls1 es' = None  (vs. stk = rev vs  length vs = length es  (is_vals es'  es' = map Val vs  xs = loc))"
proof(induct "(e', xs)" "(stk, loc, length (compE2 e), xcp)"
        and "(es', xs)" "(stk, loc, length (compEs2 es), xcp)" 
 arbitrary: e' xs stk loc xcp and es' xs stk loc xcp rule: bisim1_bisims1.inducts)
  case (bisims1List2 es es' xs stk loc pc xcp e v)
  then obtain vs where "xcp = None" "calls1 es' = None" 
    "stk = rev vs" "length vs = length es" "is_vals es'  es' = map Val vs  xs = loc" by auto
  thus ?case
    by(clarsimp)(rule_tac x="v#vs" in exI, auto)
qed(simp_all (no_asm_use), (fastforce dest: bisim1_pc_length_compE2 bisims1_pc_length_compEs2 split: bop.split_asm if_split_asm)+)

corollary bisim1_call_pcD: " P,e,h  (e', xs)  (stk, loc, pc, xcp); call1 e' = aMvs   pc < length (compE2 e)"
  and bisims1_calls_pcD: " P,es,h  (es', xs) [↔] (stk, loc, pc, xcp); calls1 es' = aMvs   pc < length (compEs2 es)"
proof -
  assume bisim: "P,e,h  (e', xs)  (stk, loc, pc, xcp)"
    and call: "call1 e' = aMvs"

  { assume "pc = length (compE2 e)"
    with bisim call have False
      by(auto dest: bisim1_pc_length_compE2D) }
  moreover from bisim have "pc  length (compE2 e)"
    by(rule bisim1_pc_length_compE2)
  ultimately show "pc < length (compE2 e)"
    by(cases "pc < length (compE2 e)")(auto)
next
  assume bisim: "P,es,h  (es', xs) [↔] (stk, loc, pc, xcp)"
    and call: "calls1 es' = aMvs"
  { assume "pc = length (compEs2 es)"
    with bisim call have False
      by(auto dest: bisims1_pc_length_compEs2D) }
  moreover from bisim have "pc  length (compEs2 es)"
    by(rule bisims1_pc_length_compEs2)
  ultimately show "pc < length (compEs2 es)"
    by(cases "pc < length (compEs2 es)")(auto)
qed

lemma bisim1_length_xs: "P,e,h  (e',xs)  (stk, loc, pc, xcp)  length xs = length loc"
  and bisims1_length_xs: "P,es,h  (es',xs) [↔] (stk, loc, pc, xcp)  length xs = length loc"
by(induct "(e',xs)" "(stk, loc, pc, xcp)" and "(es',xs)" "(stk, loc, pc, xcp)"
  arbitrary: e' xs stk loc pc xcp and es' xs stk loc pc xcp rule: bisim1_bisims1.inducts)
  auto

lemma bisim1_Val_length_compE2D:
  "P,e,h  (Val v,xs)  (stk, loc, length (compE2 e), xcp)  stk = [v]  xs = loc  xcp = None"

  and bisims1_Val_length_compEs2D:
  "P,es,h  (map Val vs,xs) [↔] (stk, loc, length (compEs2 es), xcp)  stk = rev vs  xs = loc  xcp = None"
by(auto dest: bisim1_pc_length_compE2D bisims1_pc_length_compEs2D)

lemma bisim_Val_loc_eq_xcp_None:
  "P, e, h  (Val v, xs)  (stk, loc, pc, xcp)  xs = loc  xcp = None"

  and bisims_Val_loc_eq_xcp_None:
  "P, es, h  (map Val vs, xs) [↔] (stk, loc, pc, xcp)  xs = loc  xcp = None"
apply(induct "(Val v :: 'addr expr1, xs)" "(stk, loc, pc, xcp)" 
  and "(map Val vs :: 'addr expr1 list, xs)" "(stk, loc, pc, xcp)"
  arbitrary: v xs stk loc pc xcp and vs xs stk loc pc xcp rule: bisim1_bisims1.inducts)
apply(auto)
done

lemma bisim_Val_pc_not_Invoke: 
  " P,e,h  (Val v,xs)  (stk,loc,pc,xcp); pc < length (compE2 e)   compE2 e ! pc  Invoke M n'"

  and bisims_Val_pc_not_Invoke: 
  " P,es,h  (map Val vs,xs) [↔] (stk,loc,pc,xcp); pc < length (compEs2 es)   compEs2 es ! pc  Invoke M n'"
apply(induct "(Val v :: 'addr expr1, xs)" "(stk, loc, pc, xcp)"
         and "(map Val vs :: 'addr expr1 list, xs)" "(stk, loc, pc, xcp)"
  arbitrary: v xs stk loc pc xcp and vs xs stk loc pc xcp rule: bisim1_bisims1.inducts)
apply(auto simp add: nth_append compEs2_map_Val dest: bisim1_pc_length_compE2)
done

lemma bisim1_VarD: "P, E, h  (Var V,xs)  (stk,loc,pc,xcp)  xs = loc"
  and "P, es, h  (es', xs) [↔] (stk, loc, pc, xcp)  True"
by(induct "(Var V :: 'addr expr1, xs)" "(stk, loc, pc, xcp)" and arbitrary: V xs stk loc pc xcp and rule: bisim1_bisims1.inducts) auto

lemma bisim1_ThrowD:
  "P, e, h  (Throw a, xs)  (stk, loc, pc, xcp)
   pc < length (compE2 e)  (xcp = a  xcp = None)  xs = loc"

  and bisims1_ThrowD:
  "P, es, h  (map Val vs @ Throw a # es', xs) [↔] (stk, loc, pc, xcp)
   pc < length (compEs2 es)  (xcp = a  xcp = None)  xs = loc"
apply(induct "(Throw a :: 'addr expr1, xs)" "(stk, loc, pc, xcp)"
         and "(map Val vs @ Throw a # es', xs)" "(stk, loc, pc, xcp)"
         arbitrary: xs stk loc pc xcp and vs es' xs stk loc pc xcp rule: bisim1_bisims1.inducts)
apply(fastforce dest: bisim1_pc_length_compE2 bisim_Val_loc_eq_xcp_None simp add: Cons_eq_append_conv)+
done

lemma fixes P :: "'addr J1_prog"
  shows bisim1_Invoke_stkD:
  " P,e,h  exs  (stk,loc,pc,None); pc < length (compE2 e); compE2 e ! pc = Invoke M n'  
   vs v stk'. stk = vs @ v # stk'  length vs = n'"

  and bisims1_Invoke_stkD: 
  " P,es,h  esxs [↔] (stk,loc,pc,None); pc < length (compEs2 es); compEs2 es ! pc = Invoke M n' 
   vs v stk'. stk = vs @ v # stk'  length vs = n'"
proof(induct "(stk, loc, pc, None :: 'addr option)" and "(stk, loc, pc, None :: 'addr option)"
    arbitrary: stk loc pc and stk loc pc rule: bisim1_bisims1.inducts)
  case bisim1Call1
  thus ?case
    apply(clarsimp simp add: nth_append append_eq_append_conv2 neq_Nil_conv split: if_split_asm)
    apply(drule bisim1_pc_length_compE2, clarsimp simp add: neq_Nil_conv nth_append)
    apply(frule bisim1_pc_length_compE2, clarsimp)
    apply(drule bisim1_pc_length_compE2D, fastforce)
    done
next
  case bisim1CallParams thus ?case
    apply(clarsimp simp add: nth_append append_eq_Cons_conv split: if_split_asm)
    apply(fastforce simp add: append_eq_append_conv2 Cons_eq_append_conv)
    apply(frule bisims1_pc_length_compEs2, clarsimp)
    apply(drule bisims1_pc_length_compEs2D, fastforce simp add: append_eq_append_conv2)
    done
qed(fastforce simp add: nth_append append_eq_append_conv2 neq_Nil_conv split: if_split_asm bop.split_asm dest: bisim1_pc_length_compE2 bisims1_pc_length_compEs2)+

lemma fixes P :: "'addr J1_prog"
  shows bisim1_call_xcpNone: "P,e,h  (e',xs)  (stk,loc,pc,a)  call1 e' = None"
  and bisims1_calls_xcpNone: "P,es,h  (es',xs) [↔] (stk,loc,pc,a)  calls1 es' = None"
apply(induct "(e', xs)" "(stk, loc, pc, a :: 'addr)" and "(es',xs)" "(stk, loc, pc, a :: 'addr)"
  arbitrary: e' xs stk loc pc and es' xs stk loc pc rule: bisim1_bisims1.inducts)
apply(auto dest: bisim_Val_loc_eq_xcp_None bisims_Val_loc_eq_xcp_None simp add: is_vals_conv)
done

lemma bisims1_map_Val_append:
  assumes bisim: "P, es', h  (es'', xs) [↔] (stk, loc, pc, xcp)"
  shows "length es = length vs
           P, es @ es', h  (map Val vs @ es'', xs) [↔] (stk @ rev vs, loc, length (compEs2 es) + pc, xcp)"
proof(induction vs arbitrary: es)
  case Nil thus ?case using bisim by simp
next
  case (Cons v vs)
  from ‹length es = length (v # vs) obtain e es''' where [simp]: "es = e # es'''" by(cases es, auto)
  with ‹length es = length (v # vs) have len: "length es''' = length vs" by simp
  from Cons.IH[OF len]
  show ?case by(simp add: add.assoc append_assoc[symmetric] del: append_assoc)(rule bisims1List2, auto)
qed

lemma bisim1_hext_mono: " P,e,h  exs  s; hext h h'   P,e,h'  exs  s" (is "PROP ?thesis1")
  and bisims1_hext_mono: " P,es,h  esxs [↔] s; hext h h'   P,es,h'  esxs [↔] s" (is "PROP ?thesis2")
proof -
  assume hext: "hext h h'"
  have "P,e,h  exs  s  P,e,h'  exs  s"
    and "P,es,h  esxs [↔] s  P,es,h'  esxs [↔] s"
    apply(induct rule: bisim1_bisims1.inducts)
    apply(insert hext)
    apply(auto intro: bisim1_bisims1.intros dest: hext_objD)
    done
  thus "PROP ?thesis1" and "PROP ?thesis2" by auto
qed

declare match_ex_table_append_not_pcs [simp]
       match_ex_table_eq_NoneI[simp]
       outside_pcs_compxE2_not_matches_entry[simp]
       outside_pcs_compxEs2_not_matches_entry[simp]

lemma bisim1_xcp_Some_not_caught:
  "P, e, h  (Throw a, xs)  (stk, loc, pc, a)
   match_ex_table (compP f P) (cname_of h a) (pc' + pc) (compxE2 e pc' d) = None"

  and bisims1_xcp_Some_not_caught:
  "P, es, h  (map Val vs @ Throw a # es', xs) [↔] (stk, loc, pc, a)
   match_ex_table (compP f P) (cname_of h a) (pc' + pc) (compxEs2 es pc' d) = None"
proof(induct "(Throw a :: 'addr expr1, xs)" "(stk, loc, pc, a :: 'addr)" 
    and "(map Val vs @ Throw a # es' :: 'addr expr1 list, xs)" "(stk, loc, pc, a :: 'addr)"
    arbitrary: xs stk loc pc pc' d and xs stk loc pc vs es' pc' d rule: bisim1_bisims1.inducts)
  case bisim1Sync10
  thus ?case by(simp add: matches_ex_entry_def)
next
  case bisim1Sync11
  thus ?case by(simp add: matches_ex_entry_def)
next
  case (bisim1SyncThrow e1 xs stk loc pc e2)
  note IH = ‹match_ex_table (compP f P) (cname_of h a) (pc' + pc) (compxE2 e1 pc' d) = None›
  from P,e1,h  (Throw a,xs)  (stk,loc,pc,a) have "pc < length (compE2 e1)" by(auto dest: bisim1_ThrowD)
  with IH show ?case
    by(auto simp add: match_ex_table_append matches_ex_entry_def dest: match_ex_table_pc_length_compE2 intro: match_ex_table_not_pcs_None)
next
  case bisims1List1 thus ?case
    by(auto simp add: Cons_eq_append_conv dest: bisim1_ThrowD bisim_Val_loc_eq_xcp_None)
next
  case (bisims1List2 es es'' xs stk loc pc e v)
  hence "pc' d. match_ex_table (compP f P) (cname_of h a) (pc' + pc) (compxEs2 es pc' d) = None"
    by(auto simp add: Cons_eq_append_conv)
  from this[of "pc' + length (compE2 e)" "Suc d"] show ?case by(auto simp add: add.assoc)
next
  case (bisim1BlockThrowSome e xs stk loc pc T v)
  hence "pc'. match_ex_table (compP f P) (cname_of h a) (pc' + pc) (compxE2 e pc' d) = None" by auto
  from this[of "2+pc'"] show ?case by(auto)
next
  case (bisim1Seq2 e2 stk loc pc e1 xs)
  hence "pc'. match_ex_table (compP f P) (cname_of h a) (pc' + pc) (compxE2 e2 pc' d) = None" by auto
  from this[of "Suc (pc' + length (compE2 e1))"] show ?case by(simp add: add.assoc)
next
  case (bisim1CondThen e1 stk loc pc e e2 xs)
  hence "pc'. match_ex_table (compP f P) (cname_of h a) (pc' + pc) (compxE2 e1 pc' d) = None" by auto
  note this[of "Suc (pc' + length (compE2 e))"]
  moreover from P,e1,h  (Throw a,xs)  (stk,loc,pc,a)
  have "pc < length (compE2 e1)" by(auto dest: bisim1_ThrowD)
  ultimately show ?case by(simp add: add.assoc match_ex_table_eq_NoneI outside_pcs_compxE2_not_matches_entry)
next
  case (bisim1CondElse e2 stk loc pc e e1 xs)
  hence "pc'. match_ex_table (compP f P) (cname_of h a) (pc' + pc) (compxE2 e2 pc' d) = None" by auto
  note this[of "Suc (Suc (pc' + (length (compE2 e) + length (compE2 e1))))"]
  thus ?case by(simp add: add.assoc)
next
  case (bisim1WhileThrow2 e xs stk loc pc c)
  hence "pc'. match_ex_table (compP f P) (cname_of h a) (pc' + pc) (compxE2 e pc' d) = None" by auto
  from this[of "Suc (pc' + (length (compE2 c)))"]
  show ?case by(simp add: add.assoc)
next
  case (bisim1Throw1 e xs stk loc pc)
  thus ?case by(auto dest: bisim_Val_loc_eq_xcp_None)
next
  case (bisim1TryFail e xs stk loc pc C' C e2)
  hence "match_ex_table (compP f P) (cname_of h a) (pc' + pc) (compxE2 e pc' d) = None" by auto
  moreover from P,e,h  (Throw a,xs)  (stk,loc,pc,a) have "pc < length (compE2 e)"
    by(auto dest: bisim1_ThrowD)
  ultimately show ?case using typeof_addr h a = Class_type C' ¬ P  C' * C
    by(simp add: matches_ex_entry_def cname_of_def)
next
  case (bisim1TryCatchThrow e2 xs stk loc pc e C)
  hence "pc'. match_ex_table (compP f P) (cname_of h a) (pc' + pc) (compxE2 e2 pc' d) = None" by auto
  from this[of "Suc (Suc (pc' + (length (compE2 e))))"]
  show ?case by(simp add: add.assoc matches_ex_entry_def)
next
  case bisim1Sync12 thus ?case
    by(auto dest: bisim1_ThrowD simp add: match_ex_table_append eval_nat_numeral, simp add: matches_ex_entry_def)
next
  case bisim1Sync14 thus ?case
    by(auto dest: bisim1_ThrowD simp add: match_ex_table_append eval_nat_numeral, simp add: matches_ex_entry_def)
qed(fastforce dest: bisim1_ThrowD simp add: add.assoc[symmetric])+

declare match_ex_table_append_not_pcs [simp del]
       match_ex_table_eq_NoneI[simp del]
       outside_pcs_compxE2_not_matches_entry[simp del]
       outside_pcs_compxEs2_not_matches_entry[simp del]

lemma bisim1_xcp_pcD: "P,e,h  (e', xs)  (stk, loc, pc, a)  pc < length (compE2 e)"
  and bisims1_xcp_pcD: "P,es,h  (es', xs) [↔] (stk, loc, pc, a)  pc < length (compEs2 es)"
by(induct "(e', xs)" "(stk, loc, pc, a :: 'addr)" and "(es', xs)" "(stk, loc, pc, a :: 'addr)"
  arbitrary: e' xs stk loc pc and es' xs stk loc pc rule: bisim1_bisims1.inducts)
  auto

declare nth_Cons_subtract[simp]
declare nth_append [simp]

lemma bisim1_Val_τExec_move:
  " P, E, h  (Val v, xs)  (stk, loc, pc, xcp); pc < length (compE2 E)  
   xs = loc  xcp = None 
     τExec_mover_a P t E h (stk, xs, pc, None) ([v], xs, length (compE2 E), None)"

 and bisims1_Val_τExec_moves:
  " P, Es, h  (map Val vs, xs) [↔] (stk, loc, pc, xcp); pc < length (compEs2 Es)  
   xs = loc  xcp = None 
    τExec_movesr_a P t Es h (stk, xs, pc, None) (rev vs, xs, length (compEs2 Es), None)"
proof(induct "(Val v :: 'addr expr1, xs)" "(stk, loc, pc, xcp)" 
    and "(map Val vs :: 'addr expr1 list, xs)" "(stk, loc, pc, xcp)"
    arbitrary: v xs stk loc pc xcp and vs xs stk loc pc xcp rule: bisim1_bisims1.inducts)
  case bisim1Val thus ?case by(auto intro!: τExecr1step exec_instr τmove2Val simp add: exec_move_def)
next
  case (bisim1LAss2 V e xs)
  have "τExec_mover_a P t (V:=e) h ([], xs, Suc (length (compE2 e)), None) ([Unit], xs, Suc (Suc (length (compE2 e))), None)"
    by(auto intro!: τExecr1step exec_instr τmove2LAssRed2 simp add: nth_append exec_move_def)
  with bisim1LAss2 show ?case by simp
next
  case (bisim1AAss4 a i e xs)
  have "τExec_mover_a P t (ai := e) h ([], xs, Suc (length (compE2 a) + length (compE2 i) + length (compE2 e)), None) ([Unit], xs, Suc (Suc (length (compE2 a) + length (compE2 i) + length (compE2 e))), None)"
    by(auto intro!: τExecr1step exec_instr τmove2AAssRed simp add: nth_append exec_move_def)
  with bisim1AAss4 show ?case by(simp add: ac_simps)
next
  case (bisim1FAss3 e F D e2 xs)
  have "τExec_mover_a P t (eF{D} := e2) h ([], xs, Suc (length (compE2 e) + length (compE2 e2)), None) ([Unit], xs, Suc (Suc (length (compE2 e) + length (compE2 e2))), None)"
    by(auto intro!: τExecr1step exec_instr τmove2FAssRed simp add: nth_append exec_move_def)
  with bisim1FAss3 show ?case by simp
next
  case (bisim1Sync6 V e1 e2 v xs)
  have "τExec_mover_a P t (syncV (e1) e2) h ([v], xs, 5 + length (compE2 e1) + length (compE2 e2), None)
                                        ([v], xs, 9 + length (compE2 e1) + length (compE2 e2), None)"
    by(rule τExecr1step)(auto intro: exec_instr τmove2Sync6 simp add: exec_move_def)
  with bisim1Sync6 show ?case by(auto simp add: eval_nat_numeral)
next
  case (bisim1Seq2 e2 stk loc pc xcp e1 v xs)
  from ‹Suc (length (compE2 e1) + pc) < length (compE2 (e1;; e2)) have pc: "pc < length (compE2 e2)" by simp
  with pc < length (compE2 e2)  xs = loc  xcp = None  τExec_mover_a P t e2 h (stk, xs, pc, None) ([v], xs, length (compE2 e2), None)
  have "xs = loc" "xcp = None"
    "τExec_mover_a P t e2 h (stk, xs, pc, None) ([v], xs, length (compE2 e2), None)" by auto
  moreover 
  hence "τExec_mover_a P t (e1;;e2) h (stk, xs, Suc (length (compE2 e1) + pc), None) ([v], xs, Suc (length (compE2 e1) + length (compE2 e2)), None)"
    by -(rule Seq_τExecrI2)
  ultimately show ?case by(simp)
next
  case (bisim1CondThen e1 stk loc pc xcp e e2 v xs)
  from P, e1, h  (Val v,xs)  (stk,loc,pc,xcp)
  have "pc  length (compE2 e1)" by(rule bisim1_pc_length_compE2)

  have e: "τExec_mover_a P t (if (e) e1 else e2) h
                     ([v], xs, Suc (length (compE2 e) + (length (compE2 e1))), None)
                     ([v], xs, length (compE2 (if (e) e1 else e2)), None)" 
    by(rule τExecr1step)(auto simp add: nth_append exec_move_def intro!: exec_instr τmove2CondThenExit)
  show ?case
  proof(cases "pc < length (compE2 e1)")
    case True
    with pc < length (compE2 e1)
          xs = loc  xcp = None  τExec_mover_a P t e1 h (stk, xs, pc, None) ([v], xs, length (compE2 e1), None)
    have s: "xs = loc" "xcp = None"
      and "τExec_mover_a P t e1 h (stk, xs, pc, None) ([v], xs, length (compE2 e1), None)" by auto
    hence "τExec_mover_a P t (if (e) e1 else e2) h
                     (stk, xs, Suc (length (compE2 e) + pc), None)
                     ([v], xs, Suc (length (compE2 e) + length (compE2 e1)), None)"
      by -(rule Cond_τExecrI2)
    with e True s show ?thesis by(simp)
  next
    case False
    with pc  length (compE2 e1) have pc: "pc = length (compE2 e1)" by auto
    with P, e1, h  (Val v,xs)  (stk,loc,pc,xcp)
    have "stk = [v]" "xs = loc" "xcp = None" by(auto dest: bisim1_Val_length_compE2D)
    with pc e show ?thesis by(simp)
  qed
next
  case (bisim1CondElse e2 stk loc pc xcp e e1 v xs)
  from P, e2, h  (Val v,xs)  (stk,loc,pc,xcp)
  have "pc  length (compE2 e2)" by(rule bisim1_pc_length_compE2)

  show ?case
  proof(cases "pc < length (compE2 e2)")
    case True
    with pc < length (compE2 e2)
          xs = loc  xcp = None  τExec_mover_a P t e2 h (stk, xs, pc, None) ([v], xs, length (compE2 e2), None)
    have s: "xs = loc" "xcp = None"
      and e: "τExec_mover_a P t e2 h (stk, xs, pc, None) ([v], xs, length (compE2 e2), None)" by auto
    from e have "τExec_mover_a P t (if (e) e1 else e2) h (stk, xs, Suc (Suc (length (compE2 e) + length (compE2 e1) + pc)), None) ([v], xs, Suc (Suc (length (compE2 e) + length (compE2 e1) + length (compE2 e2))), None)"
      by(rule Cond_τExecrI3)
    with True s show ?thesis by(simp add: add.assoc)
  next
    case False
    with pc  length (compE2 e2) have pc: "pc = length (compE2 e2)" by auto
    with P, e2, h  (Val v,xs)  (stk,loc,pc,xcp)
    have "stk = [v]" "xs = loc" "xcp = None" by(auto dest: bisim1_Val_length_compE2D)
    with pc show ?thesis by(simp add: add.assoc)
  qed
next
  case (bisim1While7 c e xs)
  have "τExec_mover_a P t (while (c) e) h
                   ([], xs, Suc (Suc (Suc (length (compE2 c) + length (compE2 e)))), None)
                   ([Unit], xs, length (compE2 (while (c) e)), None)"
    by(auto intro!: τExecr1step exec_instr τmove2While4 simp add: nth_append exec_move_def)
  thus ?case by(simp)
next
  case (bisims1List1 e e' xs stk loc pc xcp es)
  from e' # es = map Val vs obtain v vs' where [simp]: "vs = v # vs'" "e' = Val v" "es = map Val vs'" by auto
  from P,e,h  (e',xs)  (stk,loc,pc,xcp)
  have length: "pc  length (compE2 e)" by(auto dest: bisim1_pc_length_compE2)
  hence "xs = loc  xcp = None  τExec_mover_a P t e h (stk, xs, pc, None) ([v], xs, length (compE2 e), None)"
  proof(cases "pc < length (compE2 e)")
    case True
    with e' = Val v; pc < length (compE2 e)  xs = loc  xcp = None  τExec_mover_a P t e h (stk, xs, pc, None) ([v], xs, length (compE2 e), None)
    show ?thesis by auto
  next
    case False
    with length have pc: "pc = length (compE2 e)" by auto
    with P,e,h  (e',xs)  (stk,loc,pc,xcp) have "stk = [v]" "xs = loc" "xcp = None"
      by(auto dest: bisim1_Val_length_compE2D)
    with pc show ?thesis by(auto)
  qed
  hence s: "xs = loc" "xcp = None"
    and exec1: "τExec_mover_a P t e h (stk, xs, pc, None) ([v], xs, length (compE2 e), None)" by auto
  from exec1 have "τExec_movesr_a P t (e # es) h (stk, xs, pc, None) ([v], xs, length (compE2 e), None)"
    by(auto intro: τExec_mover_τExec_movesr)
  moreover have "τExec_movesr_a P t (map Val vs') h ([], xs, 0, None) (rev vs', xs, length (compEs2 (map Val vs')), None)"
    by(rule τExec_movesr_map_Val)
  hence "τExec_movesr_a P t ([e] @ map Val vs') h ([] @ [v], xs, length (compEs2 [e]) + 0, None) (rev vs' @ [v], xs, length (compEs2 [e]) + length (compEs2 (map Val vs')), None)"
    by -(rule append_τExec_movesr, auto)
  ultimately show ?case using s by(auto)
next
  case (bisims1List2 es es' xs stk loc pc xcp e v)
  from ‹Val v # es' = map Val vs obtain vs' where [simp]: "vs = v # vs'" "es' = map Val vs'" by auto
  from P,es,h  (es',xs) [↔] (stk,loc,pc,xcp)
  have length: "pc  length (compEs2 es)" by(auto dest: bisims1_pc_length_compEs2)
  hence "xs = loc  xcp = None  τExec_movesr_a P t es h (stk, xs, pc, None) (rev vs', xs, length (compEs2 es), None)"
  proof(cases "pc < length (compEs2 es)")
    case True
    with es' = map Val vs'; pc < length (compEs2 es)  xs = loc  xcp = None  τExec_movesr_a P t es h (stk, xs, pc, None)
      (rev vs', xs, length (compEs2 es), None)
    show ?thesis by auto
  next
    case False
    with length have pc: "pc = length (compEs2 es)" by auto
    with P,es,h  (es',xs) [↔] (stk,loc,pc,xcp) have "stk = rev vs'" "xs = loc" "xcp = None"
      by(auto dest: bisims1_Val_length_compEs2D)
    with pc show ?thesis by(auto)
  qed
  hence s: "xs = loc" "xcp = None"
    and exec1: "τExec_movesr_a P t es h (stk, xs, pc, None) (rev vs', xs, length (compEs2 es), None)" by auto
  from exec1 have "τExec_movesr_a P t ([e] @ es) h (stk @ [v], xs, length (compEs2 [e]) + pc, None) (rev vs' @ [v], xs, length (compEs2 [e]) + length (compEs2 es), None)"
    by -(rule append_τExec_movesr, auto)
  thus ?case using s by(auto)
qed(auto)

lemma bisim1Val2D1:
  assumes bisim: "P, e, h  (Val v,xs)  (stk,loc,pc,xcp)"
  shows "xcp = None  xs = loc  τExec_mover_a P t e h (stk, loc, pc, xcp) ([v], loc, length (compE2 e), None)"
proof -
  from bisim have "xcp = None" "xs = loc" by(auto dest: bisim_Val_loc_eq_xcp_None)
  moreover 
  have "τExec_mover_a P t e h (stk, loc, pc, xcp) ([v], loc, length (compE2 e), None)"
  proof(cases "pc < length (compE2 e)")
    case True
    from bisim1_Val_τExec_move[OF bisim True] show ?thesis by auto
  next
    case False
    from bisim have "pc  length (compE2 e)" by(auto dest: bisim1_pc_length_compE2)
    with False have "pc = length (compE2 e)" by auto
    with bisim have "stk = [v]" "loc = xs" "xcp=None" by(auto dest: bisim1_Val_length_compE2D)
    with pc = length (compE2 e) show ?thesis by(auto)
  qed
  ultimately show ?thesis by simp
qed

lemma bisim1_Throw_τExec_movet:
  " P, e, h  (Throw a,xs)  (stk,loc,pc,None) 
   pc'. τExec_movet_a P t e h (stk, loc, pc, None) ([Addr a], loc, pc', a) 
      P, e, h  (Throw a,xs)  ([Addr a], loc, pc', a)  xs = loc"

  and bisims1_Throw_τExec_movest:
  " P, es, h   (map Val vs @ Throw a # es',xs) [↔] (stk,loc,pc,None) 
   pc'. τExec_movest_a P t es h (stk, loc, pc, None) (Addr a # rev vs, loc, pc', a) 
      P, es, h  (map Val vs @ Throw a # es',xs) [↔] (Addr a # rev vs, loc, pc', a)  xs = loc"
proof(induct e "n :: nat" "Throw a :: 'addr expr1" xs stk loc pc "None :: 'addr option"
    and es "n :: nat" "map Val vs @ Throw a # es' :: 'addr expr1 list" xs stk loc pc "None :: 'addr option"
    arbitrary: and vs rule: bisim1_bisims1_inducts_split)
  case (bisim1Sync9 e1 n e2 V xs)
  let ?pc = "8 + length (compE2 e1) + length (compE2 e2)"
  have "τExec_movet_a P t (syncV (e1) e2) h ([Addr a], xs, ?pc, None) ([Addr a], xs, ?pc, a)"
    by(rule τExect1step)(auto intro: exec_instr τmove2_τmoves2.intros simp add: is_Ref_def exec_move_def)
  moreover
  have "P,syncV (e1) e2,h  (Throw a,xs)  ([Addr a],xs,?pc,a)" by(rule bisim1Sync10)
  ultimately show ?case by auto
next
  case (bisim1Seq2 e2 n xs stk loc pc e1)
  then obtain pc' where "τExec_movet_a P t e2 h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
    "P, e2, h  (Throw a,xs)  ([Addr a],loc,pc',a)" "xs = loc" by auto
  thus ?case by(auto intro: Seq_τExectI2 bisim1_bisims1.bisim1Seq2)
next
  case (bisim1CondThen e1 n xs stk loc pc e e2)
  then obtain pc' where exec: "τExec_movet_a P t e1 h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
    and bisim: "P, e1, h  (Throw a,xs)  ([Addr a],loc,pc',a)" and s: "xs = loc" by auto
  from exec have "τExec_movet_a P t (if (e) e1 else e2) h (stk, loc, Suc (length (compE2 e) + pc), None) ([Addr a], loc, Suc (length (compE2 e) + pc'), a)"
    by(rule Cond_τExectI2)
  moreover from bisim
  have "P, if (e) e1 else e2, h  (Throw a, xs)  ([Addr a], loc, Suc (length (compE2 e) + pc'), a)"
    by(rule bisim1_bisims1.bisim1CondThen)
  ultimately show ?case using s by(auto)
next
  case (bisim1CondElse e2 n xs stk loc pc e e1)
  then obtain pc' where exec: "τExec_movet_a P t e2 h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
    and bisim: "P, e2, h  (Throw a, xs )  ([Addr a], loc, pc', a)" and s: "xs = loc" by auto
  let "?pc pc" = "Suc (Suc (length (compE2 e) + length (compE2 e1) + pc))"
  from exec have "τExec_movet_a P t (if (e) e1 else e2) h (stk, loc, (?pc pc), None) ([Addr a], loc, ?pc pc', a)"
    by(rule Cond_τExectI3)
  moreover from bisim
  have "P, if (e) e1 else e2, h  (Throw a, xs )  ([Addr a], loc, ?pc pc', a)"
    by(rule bisim1_bisims1.bisim1CondElse)
  ultimately show ?case using s by auto
next
  case (bisim1Throw1 e n xs stk loc pc)
  note bisim = P, e, h  (addr a, xs)  (stk, loc, pc, None)
  hence s: "xs = loc" 
    and exec: "τExec_mover_a P t e h (stk, loc, pc, None) ([Addr a], loc, length (compE2 e), None)"
    by(auto dest: bisim1Val2D1)
  from exec have "τExec_mover_a P t (throw e) h (stk, loc, pc, None) ([Addr a], loc, length (compE2 e), None)"
    by(rule Throw_τExecrI)
  also have "τExec_movet_a P t (throw e) h ([Addr a], loc, length (compE2 e), None) ([Addr a], loc, length (compE2 e), a)"
    by(rule τExect1step, auto intro: exec_instr τmove2Throw2 simp add: is_Ref_def exec_move_def)
  also have "P, throw e, h  (Throw a, loc )  ([Addr a], loc, length (compE2 e), a)"
    by(rule bisim1Throw2)
  ultimately show ?case using s by auto
next
  case (bisims1List1 e n e' xs stk loc pc es vs)
  note bisim = P,e,h  (e', xs)  (stk, loc, pc, None)
  show ?case
  proof(cases "is_val e'")
    case True
    with e' # es = map Val vs @ Throw a # es' obtain v vs' where "vs = v # vs'" "e' = Val v"
      and es: "es = map Val vs' @ Throw a # es'" by(auto simp add: Cons_eq_append_conv)
    with bisim have "P,e,h  (Val v, xs)  (stk, loc, pc, None)" by simp
    from bisim1Val2D1[OF this] have [simp]: "xs = loc"
      and exec: "τExec_mover_a P t e h (stk, loc, pc, None) ([v], loc, length (compE2 e), None)"
      by auto
    from exec have "τExec_movesr_a P t (e # es) h (stk, loc, pc, None) ([v], loc, length (compE2 e), None)"
      by(rule τExec_mover_τExec_movesr)
    also from es es = map Val vs' @ Throw a # es'
          pc'. τExec_movest_a P t es h ([], loc, 0, None) (Addr a # rev vs', loc, pc', a) 
           P,es,h  (map Val vs' @ Throw a # es', loc) [↔] (Addr a # rev vs', loc, pc', a)  loc = loc
    obtain pc' where execes: "τExec_movest_a P t es h ([], loc, 0, None) (Addr a # rev vs', loc, pc', a)"
      and bisim': "P,es,h  (map Val vs' @ Throw a # es', loc) [↔] (Addr a # rev vs', loc, pc', a)" by auto
    from append_τExec_movest[OF _ execes, of "[v]" "[e]"]
    have "τExec_movest_a P t (e # es) h ([v], loc, length (compE2 e), None) (Addr a # rev vs' @ [v], loc, length (compE2 e) + pc', a)" by simp
    also from bisims1List2[OF bisim', of e v] es e' = Val v vs = v # vs'
    have "P,e # es,h  (e' # es, xs) [↔] ((Addr a # rev vs), loc, length (compE2 e) + pc', a)" by simp
    ultimately show ?thesis using vs = v # vs' es e' = Val v by auto
  next
    case False
    with e' # es = map Val vs @ Throw a # es' have [simp]: "e' = Throw a" "es = es'" "vs = []"
      by(auto simp add: Cons_eq_append_conv)
    from e' = Throw a  pc'. τExec_movet_a P t e h (stk, loc, pc, None) ([Addr a], loc, pc', a)  P,e,h  (Throw a, xs )  ([Addr a], loc, pc', a)  xs = loc
    obtain pc' where "τExec_movet_a P t e h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
      and bisim: "P,e,h  (Throw a, xs )  ([Addr a], loc, pc', a)" and s: "xs = loc" by auto
    hence "τExec_movest_a P t (e # es) h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
      by-(rule τExec_movet_τExec_movest)
    moreover from bisim
    have "P,e#es,h  (Throw a#es,xs) [↔] ([Addr a],loc,pc',a)" by(rule bisim1_bisims1.bisims1List1)
    ultimately show ?thesis using s by auto
  qed
next
  case (bisims1List2 es n es'' xs stk loc pc e v)
  note IH = vs. es'' = map Val vs @ Throw a # es'
     pc'. τExec_movest_a P t es h (stk, loc, pc, None) (Addr a # rev vs, loc, pc', a) 
           P,es,h  (map Val vs @ Throw a # es',xs) [↔] (Addr a # rev vs,loc,pc',a)  xs = loc
  from ‹Val v # es'' = map Val vs @ Throw a # es'
  obtain vs' where [simp]: "vs = v # vs'" "es'' = map Val vs' @ Throw a # es'" by(auto simp add: Cons_eq_append_conv)
  from IH[OF es'' = map Val vs' @ Throw a # es']
  obtain pc' where exec: "τExec_movest_a P t es h (stk, loc, pc, None) (Addr a # rev vs', loc, pc', a)"
    and bisim: "P,es,h  (map Val vs' @ Throw a # es',xs) [↔] (Addr a # rev vs',loc,pc',a)"
    and [simp]: "xs = loc" by auto
  from append_τExec_movest[OF _ exec, of "[v]" "[e]"]
  have "τExec_movest_a P t (e # es) h (stk @ [v], loc, length (compE2 e) + pc, None) (Addr a # rev vs, loc, length (compE2 e) + pc', a)" by simp
  moreover from bisim 
  have "P,e#es,h  (Val v # map Val vs' @ Throw a # es',xs) [↔] ((Addr a # rev vs')@[v],loc,length (compE2 e) + pc',a)"
    by(rule bisim1_bisims1.bisims1List2)
  ultimately show ?case by(auto)
qed(auto)

lemma bisim1_Throw_τExec_mover:
  " P, e, h  (Throw a,xs)  (stk,loc,pc,None) 
   pc'. τExec_mover_a P t e h (stk, loc, pc, None) ([Addr a], loc, pc', a) 
      P, e, h  (Throw a,xs)  ([Addr a], loc, pc', a)  xs = loc"
by(drule bisim1_Throw_τExec_movet)(blast intro: tranclp_into_rtranclp)

lemma bisims1_Throw_τExec_movesr:
  " P, es, h   (map Val vs @ Throw a # es',xs) [↔] (stk,loc,pc,None) 
   pc'. τExec_movesr_a P t es h (stk, loc, pc, None) (Addr a # rev vs, loc, pc', a) 
      P, es, h  (map Val vs @ Throw a # es',xs) [↔] (Addr a # rev vs, loc, pc', a)  xs = loc"
by(drule bisims1_Throw_τExec_movest)(blast intro: tranclp_into_rtranclp)

declare split_beta [simp]

lemma bisim1_inline_call_Throw:
  " P,e,h  (e', xs)  (stk, loc, pc, None); call1 e' = (a, M, vs);
     compE2 e ! pc = Invoke M n0; pc < length (compE2 e) 
   n0 = length vs  P,e,h  (inline_call (Throw A) e', xs)  (stk, loc, pc, A)"
  (is " _; _; _; _   ?concl e n e' xs pc stk loc")

  and bisims1_inline_calls_Throw:
  " P,es,h  (es', xs) [↔] (stk, loc, pc, None); calls1 es' = (a, M, vs);
     compEs2 es ! pc = Invoke M n0; pc < length (compEs2 es) 
   n0 = length vs  P,es,h  (inline_calls (Throw A) es', xs) [↔] (stk, loc, pc, A)"
  (is " _; _; _; _   ?concls es n es' xs pc stk loc")
proof(induct e "n :: nat" e' xs stk loc pc "None :: 'addr option"
        and es "n :: nat" es' xs stk loc pc "None :: 'addr option"
      rule: bisim1_bisims1_inducts_split)
  case (bisim1BinOp1 e1 n e' xs stk loc pc e2 bop)
  note IH1 = call1 e' = (a, M, vs); compE2 e1 ! pc = Invoke M n0; pc < length (compE2 e1) 
               ?concl e1 n e' xs pc stk loc
  note bisim1 = P,e1,h  (e', xs)  (stk, loc, pc, None)
  note ins = ‹compE2 (e1 «bop» e2) ! pc = Invoke M n0
  note call = ‹call1 (e' «bop» e2) = (a, M, vs)
  show ?case
  proof(cases "is_val e'")
    case False
    with bisim1 call have "pc < length (compE2 e1)"
      by(auto intro: bisim1_call_pcD)
    with call ins IH1 False show ?thesis
      by(auto simp add: nth_append intro: bisim1_bisims1.bisim1BinOp1)
  next
    case True
    then obtain v where [simp]: "e' = Val v" by auto
    from bisim1 have "pc  length (compE2 e1)" by(auto dest: bisim1_pc_length_compE2)
    moreover {
      assume pc: "pc < length (compE2 e1)"
      with bisim1 ins have False
        by(auto dest: bisim_Val_pc_not_Invoke simp add: nth_append) }
    ultimately have [simp]: "pc = length (compE2 e1)" by(cases "pc < length (compE2 e1)") auto
    from call ins show ?thesis by simp
  qed
next
  case bisim1BinOp2 thus ?case
    by(auto split: if_split_asm bop.split_asm dest: bisim1_bisims1.bisim1BinOp2)
next
  case (bisim1AAcc1 A n a' xs stk loc pc i)
  note IH1 = call1 a' = (a, M, vs); compE2 A ! pc = Invoke M n0; pc < length (compE2 A) 
               ?concl A n a' xs pc stk loc
  note bisim1 = P,A,h  (a', xs)  (stk, loc, pc, None)
  note ins = ‹compE2 (Ai) ! pc = Invoke M n0
  note call = ‹call1 (a'i) = (a, M, vs)
  show ?case
  proof(cases "is_val a'")
    case False
    with bisim1 call have "pc < length (compE2 A)"
      by(auto intro: bisim1_call_pcD)
    with call ins IH1 False show ?thesis
      by(auto simp add: nth_append intro: bisim1_bisims1.bisim1AAcc1)
  next
    case True
    then obtain v where [simp]: "a' = Val v" by auto
    from bisim1 have "pc  length (compE2 A)" by(auto dest: bisim1_pc_length_compE2)
    moreover {
      assume pc: "pc < length (compE2 A)"
      with bisim1 ins have False
        by(auto dest: bisim_Val_pc_not_Invoke simp add: nth_append) }
    ultimately have [simp]: "pc = length (compE2 A)" by(cases "pc < length (compE2 A)") auto
    from call ins show ?thesis by simp
  qed
next
  case bisim1AAcc2 thus ?case
    by(auto split: if_split_asm dest: bisim1_bisims1.bisim1AAcc2)
next
  case (bisim1AAss1 A n a' xs stk loc pc i e)
  note IH1 = call1 a' = (a, M, vs); compE2 A ! pc = Invoke M n0; pc < length (compE2 A) 
               ?concl A n a' xs pc stk loc
  note bisim1 = P,A,h  (a', xs)  (stk, loc, pc, None)
  note ins = ‹compE2 (Ai := e) ! pc = Invoke M n0
  note call = ‹call1 (a'i := e) = (a, M, vs)
  show ?case
  proof(cases "is_val a'")
    case False
    with bisim1 call have "pc < length (compE2 A)"
      by(auto intro: bisim1_call_pcD)
    with call ins IH1 False show ?thesis
      by(auto simp add: nth_append intro: bisim1_bisims1.bisim1AAss1)
  next
    case True
    then obtain v where [simp]: "a' = Val v" by auto
    from bisim1 have "pc  length (compE2 A)" by(auto dest: bisim1_pc_length_compE2)
    moreover {
      assume pc: "pc < length (compE2 A)"
      with bisim1 ins have False
        by(auto dest: bisim_Val_pc_not_Invoke simp add: nth_append) }
    ultimately have [simp]: "pc = length (compE2 A)" by(cases "pc < length (compE2 A)") auto
    from call ins show ?thesis by simp
  qed
next
  case (bisim1AAss2 i n i' xs stk loc pc A e v)
  note IH1 = call1 i' = (a, M, vs); compE2 i ! pc = Invoke M n0; pc < length (compE2 i) 
               ?concl i n i' xs pc stk loc
  note bisim1 = P,i,h  (i', xs)  (stk, loc, pc, None)
  note ins = ‹compE2 (Ai := e) ! (length (compE2 A) + pc) = Invoke M n0
  note call = ‹call1 (Val vi' := e) = (a, M, vs)
  show ?case
  proof(cases "is_val i'")
    case False
    with bisim1 call have "pc < length (compE2 i)"
      by(auto intro: bisim1_call_pcD)
    with call ins IH1 False show ?thesis
      by(auto simp add: nth_append intro: bisim1_bisims1.bisim1AAss2)
  next
    case True
    then obtain v where [simp]: "i' = Val v" by auto
    from bisim1 have "pc  length (compE2 i)" by(auto dest: bisim1_pc_length_compE2)
    moreover {
      assume pc: "pc < length (compE2 i)"
      with bisim1 ins have False
        by(auto dest: bisim_Val_pc_not_Invoke simp add: nth_append) }
    ultimately have [simp]: "pc = length (compE2 i)" by(cases "pc < length (compE2 i)") auto
    from call ins show ?thesis by simp
  qed
next
  case bisim1AAss3 thus ?case
    by(auto split: if_split_asm nat.split_asm simp add: nth_Cons dest: bisim1_bisims1.bisim1AAss3)
next
  case (bisim1FAss1 e n e' xs stk loc pc e2 F D)
  note IH1 = call1 e' = (a, M, vs); compE2 e ! pc = Invoke M n0; pc < length (compE2 e) 
               ?concl e n e' xs pc stk loc
  note bisim1 = P,e,h  (e', xs)  (stk, loc, pc, None)
  note ins = ‹compE2 (eF{D} := e2) ! pc = Invoke M n0
  note call = ‹call1 (e'F{D} := e2) = (a, M, vs)
  show ?case
  proof(cases "is_val e'")
    case False
    with bisim1 call have "pc < length (compE2 e)"
      by(auto intro: bisim1_call_pcD)
    with call ins IH1 False show ?thesis
      by(auto simp add: nth_append intro: bisim1_bisims1.bisim1FAss1)
  next
    case True
    then obtain v where [simp]: "e' = Val v" by auto
    from bisim1 have "pc  length (compE2 e)" by(auto dest: bisim1_pc_length_compE2)
    moreover {
      assume pc: "pc < length (compE2 e)"
      with bisim1 ins have False
        by(auto dest: bisim_Val_pc_not_Invoke simp add: nth_append) }
    ultimately have [simp]: "pc = length (compE2 e)" by(cases "pc < length (compE2 e)") auto
    from call ins show ?thesis by simp
  qed
next
  case bisim1FAss2 thus ?case
    by(auto split: if_split_asm nat.split_asm simp add: nth_Cons dest: bisim1_bisims1.bisim1FAss2)
next
  case (bisim1CAS1 E n e' xs stk loc pc e2 e3 D F)
  note IH1 = call1 e' = (a, M, vs); compE2 E ! pc = Invoke M n0; pc < length (compE2 E) 
               ?concl E n e' xs pc stk loc
  note bisim1 = P,E,h  (e', xs)  (stk, loc, pc, None)
  note ins = ‹compE2 _ ! pc = Invoke M n0
  note call = ‹call1 _ = (a, M, vs)
  show ?case
  proof(cases "is_val e'")
    case False
    with bisim1 call have "pc < length (compE2 E)"
      by(auto intro: bisim1_call_pcD)
    with call ins IH1 False show ?thesis
      by(auto simp add: nth_append intro: bisim1_bisims1.bisim1CAS1)
  next
    case True
    then obtain v where [simp]: "e' = Val v" by auto
    from bisim1 have "pc  length (compE2 E)" by(auto dest: bisim1_pc_length_compE2)
    moreover {
      assume pc: "pc < length (compE2 E)"
      with bisim1 ins have False
        by(auto dest: bisim_Val_pc_not_Invoke simp add: nth_append) }
    ultimately have [simp]: "pc = length (compE2 E)" by(cases "pc < length (compE2 E)") auto
    from call ins show ?thesis by simp
  qed
next
  case (bisim1CAS2 e2 n e2' xs stk loc pc e1 e3 D F v)
  note IH1 = call1 e2' = (a, M, vs); compE2 e2 ! pc = Invoke M n0; pc < length (compE2 e2) 
               ?concl e2 n e2' xs pc stk loc
  note bisim1 = P,e2,h  (e2', xs)  (stk, loc, pc, None)
  note ins = ‹compE2 _ ! (length (compE2 e1) + pc) = Invoke M n0
  note call = ‹call1 _ = (a, M, vs)
  show ?case
  proof(cases "is_val e2'")
    case False
    with bisim1 call have "pc < length (compE2 e2)"
      by(auto intro: bisim1_call_pcD)
    with call ins IH1 False show ?thesis
      by(auto simp add: nth_append intro: bisim1_bisims1.bisim1CAS2)
  next
    case True
    then obtain v where [simp]: "e2' = Val v" by auto
    from bisim1 have "pc  length (compE2 e2)" by(auto dest: bisim1_pc_length_compE2)
    moreover {
      assume pc: "pc < length (compE2 e2)"
      with bisim1 ins have False
        by(auto dest: bisim_Val_pc_not_Invoke simp add: nth_append) }
    ultimately have [simp]: "pc = length (compE2 e2)" by(cases "pc < length (compE2 e2)") auto
    from call ins show ?thesis by simp
  qed
next
  case (bisim1Call1 obj n obj' xs stk loc pc ps M')
  note IH1 = call1 obj' = (a, M, vs); compE2 obj ! pc = Invoke M n0;
              pc < length (compE2 obj) 
               ?concl obj n obj' xs pc stk loc
  note IH2 = xs. calls1 ps = (a, M, vs); compEs2 ps ! 0 = Invoke M n0; 0 < length (compEs2 ps) 
              ?concls ps n ps xs 0 [] xs
  note ins = ‹compE2 (objM'(ps)) ! pc = Invoke M n0
  note bisim1 = P,obj,h  (obj', xs)  (stk, loc, pc, None)
  note call = ‹call1 (obj'M'(ps)) = (a, M, vs)
  thus ?case
  proof(cases rule: call1_callE)
    case CallObj
    with bisim1 call have "pc < length (compE2 obj)" by(auto intro: bisim1_call_pcD)
    with call ins CallObj IH1 show ?thesis
      by(auto intro: bisim1_bisims1.bisim1Call1)
  next
    case (CallParams v)
    from bisim1 have "pc  length (compE2 obj)" by(auto dest: bisim1_pc_length_compE2)
    moreover {
      assume pc: "pc < length (compE2 obj)"
      with bisim1 ins CallParams have False by(auto dest: bisim_Val_pc_not_Invoke) }
    ultimately have [simp]: "pc = length (compE2 obj)" by(cases "pc < length (compE2 obj)") auto
    with bisim1 CallParams have [simp]: "stk = [v]" "loc = xs" by(auto dest: bisim1_Val_length_compE2D)
    from IH2[of loc] CallParams ins
    show ?thesis
      apply(clarsimp simp add: compEs2_map_Val is_vals_conv split: if_split_asm)
      apply(drule bisim1_bisims1.bisim1CallParams)
      apply(auto simp add: neq_Nil_conv)
      done
  next
    case [simp]: Call
    from bisim1 have "pc  length (compE2 obj)" by(auto dest: bisim1_pc_length_compE2)
    moreover {
      assume pc: "pc < length (compE2 obj)"
      with bisim1 ins have False by(auto dest: bisim_Val_pc_not_Invoke simp add: nth_append) }
    ultimately have [simp]: "pc = length (compE2 obj)" by(cases "pc < length (compE2 obj)") auto
    with ins have [simp]: "vs = []" by(auto simp add: nth_append compEs2_map_Val split: if_split_asm)
    from bisim1 have [simp]: "stk = [Addr a]" "xs = loc" by(auto dest: bisim1_Val_length_compE2D)
    from ins show ?thesis by(auto intro: bisim1CallThrow[of "[]" "[]", simplified])
  qed
next
  case (bisim1CallParams ps n ps' xs stk loc pc obj M' v)
  note IH2 = calls1 ps' = (a, M, vs); compEs2 ps ! pc = Invoke M n0; pc < length (compEs2 ps) 
              ?concls ps n ps' xs pc stk loc
  note ins = ‹compE2 (objM'(ps)) ! (length (compE2 obj) + pc) = Invoke M n0
  note bisim2 = P,ps,h  (ps', xs) [↔] (stk, loc, pc, None)
  note call = ‹call1 (Val vM'(ps')) = (a, M, vs)
  thus ?case
  proof(cases rule: call1_callE)
    case CallObj thus ?thesis by simp
  next
    case (CallParams v')
    hence [simp]: "v' = v" and call': "calls1 ps' = (a, M, vs)" by auto
    from bisim2 call' have "pc < length (compEs2 ps)" by(auto intro: bisims1_calls_pcD)
    with IH2 CallParams ins show ?thesis
      by(auto simp add: is_vals_conv split: if_split_asm intro: bisim1_bisims1.bisim1CallParams)
  next
    case Call
    hence [simp]: "v = Addr a" "M' = M" "ps' = map Val vs" by auto
    from bisim2 have "pc  length (compEs2 ps)" by(auto dest: bisims1_pc_length_compEs2)
    moreover {
      assume pc: "pc < length (compEs2 ps)"
      with bisim2 ins have False by(auto dest: bisims_Val_pc_not_Invoke simp add: nth_append) }
    ultimately have [simp]: "pc = length (compEs2 ps)" by(cases "pc < length (compEs2 ps)") auto
    from bisim2 have [simp]: "stk = rev vs" "xs = loc" by(auto dest: bisims1_Val_length_compEs2D)
    from bisim2 have "length ps = length vs" by(auto dest: bisims1_lengthD)
    with ins show ?thesis by(auto intro: bisim1CallThrow)
  qed
next
  case (bisims1List1 e n e' xs stk loc pc es)
  note IH1 = call1 e' = (a, M, vs); compE2 e ! pc = Invoke M n0; pc < length (compE2 e) 
               ?concl e n e' xs pc stk loc
  note IH2 = xs. calls1 es = (a, M, vs); compEs2 es ! 0 = Invoke M n0; 0 < length (compEs2 es) 
              ?concls es n es xs 0 [] xs
  note bisim1 = P,e,h  (e', xs)  (stk, loc, pc, None)
  note call = ‹calls1 (e' # es) = (a, M, vs)
  note ins = ‹compEs2 (e # es) ! pc = Invoke M n0
  show ?case
  proof(cases "is_val e'")
    case False
    with bisim1 call have "pc < length (compE2 e)" by(auto intro: bisim1_call_pcD)
    with call ins False IH1 show ?thesis
      by(auto simp add: nth_append split_beta intro: bisim1_bisims1.bisims1List1)
  next
    case True
    then obtain v where [simp]: "e' = Val v" by auto
    from bisim1 have "pc  length (compE2 e)" by(auto dest: bisim1_pc_length_compE2)
    moreover {
      assume pc: "pc < length (compE2 e)"
      with bisim1 ins have False by(auto dest: bisim_Val_pc_not_Invoke simp add: nth_append) }
    ultimately have [simp]: "pc = length (compE2 e)" by(cases "pc < length (compE2 e)") auto
    with bisim1 have [simp]: "stk = [v]" "loc = xs" by(auto dest: bisim1_Val_length_compE2D)
    from call have "es  []" by(cases es) simp_all
    with IH2[of loc] call ins
    show ?thesis by(auto split: if_split_asm dest: bisims1List2)
  qed
qed(auto split: if_split_asm bop.split_asm intro: bisim1_bisims1.intros dest: bisim1_pc_length_compE2)

lemma bisim1_max_stack: "P,e,h  (e', xs)  (stk, loc, pc, xcp)  length stk  max_stack e"
  and bisims1_max_stacks: "P,es,h  (es', xs) [↔] (stk, loc, pc, xcp)  length stk  max_stacks es"
apply(induct "(e', xs)" "(stk, loc, pc, xcp)" and "(es', xs)" "(stk, loc, pc, xcp)"
  arbitrary: e' xs stk loc pc xcp and es' xs stk loc pc xcp rule: bisim1_bisims1.inducts)
apply(auto simp add: max_stack1[simplified] max_def max_stacks_ge_length)
apply(drule sym, simp add: max_stacks_ge_length, drule sym, simp, rule le_trans[OF max_stacks_ge_length], simp)
done

inductive bisim1_fr :: "'addr J1_prog  'heap  'addr expr1 × 'addr locals1  'addr frame  bool"
for P :: "'addr J1_prog" and h :: 'heap
where
  " P  C sees M:TsT = body in D;
     P,blocks1 0 (Class D#Ts) body, h  (e, xs)  (stk, loc, pc, None);
     call1 e = (a, M', vs);
     max_vars e  length xs 
   bisim1_fr P h (e, xs) (stk, loc, C, M, pc)"

declare bisim1_fr.intros [intro]
declare bisim1_fr.cases [elim]

lemma bisim1_fr_hext_mono:
  " bisim1_fr P h exs fr; hext h h'    bisim1_fr P h' exs fr"
by(auto intro: bisim1_hext_mono)

lemma bisim1_max_vars: "P,E,h  (e, xs)  (stk, loc, pc, xcp)  max_vars E  max_vars e"
  and bisims1_max_varss: "P,Es,h  (es,xs) [↔] (stk,loc,pc,xcp)  max_varss Es  max_varss es"
apply(induct E "(e, xs)" "(stk, loc, pc, xcp)" and Es "(es, xs)" "(stk, loc, pc, xcp)"
  arbitrary: e xs stk loc pc xcp and es xs stk loc pc xcp rule: bisim1_bisims1.inducts)
apply(auto)
done

lemma bisim1_call_τExec_move:
  " P,e,h  (e', xs)  (stk, loc, pc, None); call1 e' = (a, M', vs); n + max_vars e'  length xs; ¬ contains_insync e 
   pc' loc' stk'. τExec_mover_a P t e h (stk, loc, pc, None) (rev vs @ Addr a # stk', loc', pc', None) 
                     pc' < length (compE2 e)  compE2 e ! pc' = Invoke M' (length vs) 
                     P,e,h  (e', xs)  (rev vs @ Addr a # stk', loc', pc', None)"
  (is " _; _; _; _   ?concl e n e' xs pc stk loc")

  and bisims1_calls_τExec_moves:
  " P,es,h  (es',xs) [↔] (stk, loc, pc, None); calls1 es' = (a, M', vs);
     n + max_varss es'  length xs; ¬ contains_insyncs es 
   pc' stk' loc'. τExec_movesr_a P t es h (stk, loc, pc, None) (rev vs @ Addr a # stk', loc', pc', None) 
                     pc' < length (compEs2 es)  compEs2 es ! pc' = Invoke M' (length vs) 
                     P,es,h  (es', xs) [↔] (rev vs @ Addr a # stk', loc', pc', None)"
  (is "_; _; _; _   ?concls es n es' xs pc stk loc")
proof(induct e "n :: nat" e' xs stk loc pc xcp"None :: 'addr option"
    and es "n :: nat" es' xs stk loc pc xcp"None :: 'addr option"
    rule: bisim1_bisims1_inducts_split)
  case bisim1Val2 thus ?case by auto
next
  case bisim1New thus ?case by auto
next
  case bisim1NewArray thus ?case
    by auto (fastforce intro: bisim1_bisims1.bisim1NewArray elim!: NewArray_τExecrI intro!: exI)
next
  case bisim1Cast thus ?case
    by(auto)(fastforce intro: bisim1_bisims1.bisim1Cast elim!: Cast_τExecrI intro!: exI)+
next
  case bisim1InstanceOf thus ?case
    by(auto)(fastforce intro: bisim1_bisims1.bisim1InstanceOf elim!: InstanceOf_τExecrI intro!: exI)+
next
  case bisim1Val thus ?case by auto
next
  case bisim1Var thus ?case by auto
next
  case (bisim1BinOp1 e1 n e' xs stk loc pc e2 bop)
  note IH1 = call1 e' = (a, M', vs); n + max_vars e'  length xs; ¬ contains_insync e1   ?concl e1 n e' xs pc stk loc
  note IH2 = xs. call1 e2 = (a, M', vs); n + max_vars e2  length xs; ¬ contains_insync e2   ?concl e2 n e2 xs 0 [] xs
  note call = ‹call1 (e' «bop» e2) = (a, M', vs)
  note len = n + max_vars (e' «bop» e2)  length xs
  note bisim1 = P,e1,h  (e', xs)  (stk, loc, pc, None)
  note cs = ¬ contains_insync (e1 «bop» e2)
  show ?case
  proof(cases "is_val e'")
    case True
    then obtain v where [simp]: "e' = Val v" by auto
    from bisim1 have "τExec_mover_a P t e1 h (stk, loc, pc, None) ([v], loc, length (compE2 e1), None)"
      and [simp]: "xs = loc" by(auto dest!: bisim1Val2D1)
    hence "τExec_mover_a P t (e1«bop»e2) h (stk, loc, pc, None) ([v], loc, length (compE2 e1), None)"
      by-(rule BinOp_τExecrI1)
    also from call IH2[of loc] len cs  obtain pc' stk' loc'
      where exec: "τExec_mover_a P t e2 h ([], xs, 0, None) (rev vs @ Addr a # stk', loc', pc', None)"
      and ins: "compE2 e2 ! pc' = Invoke M' (length vs)" "pc' < length (compE2 e2)"
      and bisim': "P,e2,h  (e2, xs)  (rev vs @ Addr a # stk', loc', pc', None)" by auto
    from BinOp_τExecrI2[OF exec, of e1 bop v]
    have "τExec_mover_a P t (e1«bop»e2) h ([v], loc, length (compE2 e1), None) (rev vs @ Addr a # (stk' @ [v]), loc', length (compE2 e1) + pc', None)" by simp
    also (rtranclp_trans) from bisim'
    have "P,e1«bop»e2,h  (Val v «bop» e2, xs)  ((rev vs @ Addr a # stk') @ [v], loc', length (compE2 e1) + pc', None)"
      by(rule bisim1BinOp2)
    ultimately show ?thesis using ins by fastforce
  next
    case False with IH1 len False call cs show ?thesis
      by(clarsimp)(fastforce intro: bisim1_bisims1.bisim1BinOp1 elim!: BinOp_τExecrI1 intro!: exI)
  qed
next
  case (bisim1BinOp2 e2 n e' xs stk loc pc e1 bop v1)
  then obtain pc' loc' stk' where pc': "pc' < length (compE2 e2)" "compE2 e2 ! pc' = Invoke M' (length vs)"
    and exec: "τExec_mover_a P t e2 h (stk, loc, pc, None) (rev vs @ Addr a # stk', loc', pc', None)"
    and bisim': "P,e2,h  (e', xs)  (rev vs @ Addr a # stk', loc', pc', None)" by fastforce
  from exec have "τExec_mover_a P t (e1 «bop» e2) h (stk @ [v1], loc, length (compE2 e1) + pc, None)
                                              ((rev vs @ Addr a # stk') @ [v1], loc', length (compE2 e1) + pc', None)"
    by(rule BinOp_τExecrI2)
  moreover from bisim'
  have "P,e1 «bop» e2,h  (Val v1 «bop» e', xs)  ((rev vs @ Addr a # stk') @ [v1], loc', length (compE2 e1) + pc', None)"
    by(rule bisim1_bisims1.bisim1BinOp2)
  ultimately show ?case using pc' by(fastforce)
next
  case bisim1LAss1 thus ?case
    by(auto)(fastforce intro: bisim1_bisims1.bisim1LAss1 elim!: LAss_τExecrI intro!: exI)
next
  case bisim1LAss2 thus ?case by simp
next
  case (bisim1AAcc1 A n a' xs stk loc pc i)
  note IH1 = call1 a' = (a, M', vs); n + max_vars a'  length xs; ¬ contains_insync A  ?concl A n a' xs pc stk loc
  note IH2 = xs. call1 i = (a, M', vs); n + max_vars i  length xs; ¬ contains_insync i  ?concl i n i xs 0 [] xs
  note call = ‹call1 (a'i) = (a, M', vs)
  note len = n + max_vars (a'i)  length xs
  note bisim1 = P,A,h  (a', xs)  (stk, loc, pc, None)
  note cs = ¬ contains_insync (Ai)
  show ?case
  proof(cases "is_val a'")
    case True
    then obtain v where [simp]: "a' = Val v" by auto
    from bisim1 have "τExec_mover_a P t A h (stk, loc, pc, None) ([v], loc, length (compE2 A), None)"
      and [simp]: "xs = loc" by(auto dest!: bisim1Val2D1)
    hence "τExec_mover_a P t (Ai) h (stk, loc, pc, None) ([v], loc, length (compE2 A), None)"
      by-(rule AAcc_τExecrI1)
    also from call IH2[of loc] len cs obtain pc' stk' loc'
      where exec: "τExec_mover_a P t i h ([], xs, 0, None) (rev vs @ Addr a # stk', loc', pc', None)"
      and ins: "compE2 i ! pc' = Invoke M' (length vs)" "pc' < length (compE2 i)"
      and bisim': "P,i,h  (i, xs)  (rev vs @ Addr a # stk', loc', pc', None)" by auto
    from AAcc_τExecrI2[OF exec, of A v]
    have "τExec_mover_a P t (Ai) h ([v], loc, length (compE2 A), None) (rev vs @ Addr a # (stk' @ [v]), loc', length (compE2 A) + pc', None)" by simp
    also (rtranclp_trans) from bisim'
    have "P,Ai,h  (Val vi, xs)  ((rev vs @ Addr a # stk') @ [v], loc', length (compE2 A) + pc', None)"
      by(rule bisim1AAcc2)
    ultimately show ?thesis using ins by fastforce
  next
    case False with IH1 len False call cs show ?thesis
      by(clarsimp)(fastforce intro: bisim1_bisims1.bisim1AAcc1 elim!: AAcc_τExecrI1 intro!: exI)
  qed
next
  case (bisim1AAcc2 i n i' xs stk loc pc A v)
  then obtain pc' loc' stk' where pc': "pc' < length (compE2 i)" "compE2 i ! pc' = Invoke M' (length vs)"
    and exec: "τExec_mover_a P t i h (stk, loc, pc, None) (rev vs @ Addr a # stk', loc', pc', None)"
    and bisim': "P,i,h  (i', xs)  (rev vs @ Addr a # stk', loc', pc', None)" by fastforce
  from exec have "τExec_mover_a P t (Ai) h (stk @ [v], loc, length (compE2 A) + pc, None)
                                       ((rev vs @ Addr a # stk') @ [v], loc', length (compE2 A) + pc', None)"
    by(rule AAcc_τExecrI2)
  moreover from bisim'
  have "P,Ai,h  (Val vi', xs)  ((rev vs @ Addr a # stk') @ [v], loc', length (compE2 A) + pc', None)"
    by(rule bisim1_bisims1.bisim1AAcc2)
  ultimately show ?case using pc' by(fastforce)
next
  case (bisim1AAss1 A n a' xs stk loc pc i e)
  note IH1 = call1 a' = (a, M', vs); n + max_vars a'  length xs; ¬ contains_insync A   ?concl A n a' xs pc stk loc
  note IH2 = xs. call1 i = (a, M', vs); n + max_vars i  length xs; ¬ contains_insync i  ?concl i n i xs 0 [] xs
  note IH3 = xs. call1 e = (a, M', vs); n + max_vars e  length xs; ¬ contains_insync e  ?concl e n e xs 0 [] xs
  note call = ‹call1 (a'i := e) = (a, M', vs)
  note len = n + max_vars (a'i := e)  length xs
  note bisim1 = P,A,h  (a', xs)  (stk, loc, pc, None)
  note bisim2 = P,i,h  (i, loc)  ([], loc, 0, None)
  note cs = ¬ contains_insync (Ai := e)
  show ?case
  proof(cases "is_val a'")
    case True
    then obtain v where [simp]: "a' = Val v" by auto
    from bisim1 have "τExec_mover_a P t A h (stk, loc, pc, None) ([v], loc, length (compE2 A), None)"
      and [simp]: "xs = loc" by(auto dest!: bisim1Val2D1)
    hence exec: "τExec_mover_a P t (Ai := e) h (stk, loc, pc, None) ([v], loc, length (compE2 A), None)"
      by-(rule AAss_τExecrI1)
    show ?thesis
    proof(cases "is_val i")
      case True
      then obtain v' where [simp]: "i = Val v'" by auto
      note exec also from bisim2
      have "τExec_mover_a P t i h ([], loc, 0, None) ([v'], loc, length (compE2 i), None)"
        by(auto dest!: bisim1Val2D1)
      from AAss_τExecrI2[OF this, of A e v]
      have "τExec_mover_a P t (Ai := e) h ([v], loc, length (compE2 A), None) ([v', v], loc, length (compE2 A) + length (compE2 i), None)" by simp
      also (rtranclp_trans) from call IH3[of loc] len cs obtain pc' stk' loc'
        where exec: "τExec_mover_a P t e h ([], loc, 0, None) (rev vs @ Addr a # stk', loc', pc', None)"
        and ins: "compE2 e ! pc' = Invoke M' (length vs)" "pc' < length (compE2 e)"
        and bisim': "P,e,h  (e, loc)  (rev vs @ Addr a # stk', loc', pc', None)" by auto
      from AAss_τExecrI3[OF exec, of A i v' v]
      have "τExec_mover_a P t (Ai := e) h ([v', v], loc, length (compE2 A) + length (compE2 i), None)
                        ((rev vs @ Addr a # stk') @ [v', v], loc', length (compE2 A) + length (compE2 i) + pc', None)" by simp
      also (rtranclp_trans) from bisim'
      have "P,Ai := e,h  (Val vVal v' := e, xs)  ((rev vs @ Addr a # stk') @ [v', v], loc', length (compE2 A) + length (compE2 i) + pc', None)"
        by - (rule bisim1AAss3, simp)
      ultimately show ?thesis using ins by fastforce
    next
      case False
      note exec also from False call IH2[of loc] len cs obtain pc' stk' loc'
        where exec: "τExec_mover_a P t i h ([], xs, 0, None) (rev vs @ Addr a # stk', loc', pc', None)"
        and ins: "compE2 i ! pc' = Invoke M' (length vs)" "pc' < length (compE2 i)"
        and bisim': "P,i,h  (i, xs)  (rev vs @ Addr a # stk', loc', pc', None)" by auto
      from AAss_τExecrI2[OF exec, of A e v]
      have "τExec_mover_a P t (Ai := e) h ([v], loc, length (compE2 A), None) (rev vs @ Addr a # (stk' @ [v]), loc', length (compE2 A) + pc', None)" by simp
      also (rtranclp_trans) from bisim'
      have "P,Ai := e,h  (Val vi := e, xs)  ((rev vs @ Addr a # stk') @ [v], loc', length (compE2 A) + pc', None)"
        by(rule bisim1AAss2)
      ultimately show ?thesis using ins False by(fastforce intro!: exI)
    qed
  next
    case False with IH1 len False call cs show ?thesis
      by(clarsimp)(fastforce intro: bisim1_bisims1.bisim1AAss1 elim!: AAss_τExecrI1 intro!: exI)
  qed
next
  case (bisim1AAss2 i n i' xs stk loc pc A e v)
  note IH2 = call1 i' = (a, M', vs); n + max_vars i'  length xs; ¬ contains_insync i  ?concl i n i' xs pc stk loc
  note IH3 = xs. call1 e = (a, M', vs); n + max_vars e  length xs; ¬ contains_insync e  ?concl e n e xs 0 [] xs
  note call = ‹call1 (Val vi' := e) = (a, M', vs)
  note len = n + max_vars (Val vi' := e)  length xs
  note bisim2 = P,i,h  (i', xs)  (stk, loc, pc, None)
  note cs = ¬ contains_insync (Ai := e)
  show ?case
  proof(cases "is_val i'")
    case True
    then obtain v' where [simp]: "i' = Val v'" by auto
    from bisim2 have exec: "τExec_mover_a P t i h (stk, loc, pc, None) ([v'], loc, length (compE2 i), None)"
      and [simp]: "xs = loc" by(auto dest!: bisim1Val2D1)
    from AAss_τExecrI2[OF exec, of A e v]
    have "τExec_mover_a P t (Ai := e) h (stk @ [v], loc, length (compE2 A) + pc, None) ([v', v], loc, length (compE2 A) + length (compE2 i), None)" by simp
    also from call IH3[of loc] len cs obtain pc' stk' loc'
      where exec: "τExec_mover_a P t e h ([], xs, 0, None) (rev vs @ Addr a # stk', loc', pc', None)"
      and ins: "compE2 e ! pc' = Invoke M' (length vs)" "pc' < length (compE2 e)"
      and bisim': "P,e,h  (e, xs)  (rev vs @ Addr a # stk', loc', pc', None)" by auto
    from AAss_τExecrI3[OF exec, of A i v' v]
    have "τExec_mover_a P t (Ai := e) h ([v', v], loc, length (compE2 A) + length (compE2 i), None)
                       ((rev vs @ Addr a # stk') @ [v', v], loc', length (compE2 A) + length (compE2 i) + pc', None)" by simp
    also (rtranclp_trans) from bisim'
    have "P,Ai := e,h  (Val vVal v' := e, xs)  ((rev vs @ Addr a # stk') @ [v', v], loc', length (compE2 A) + length (compE2 i) + pc', None)"
      by(rule bisim1AAss3)
    ultimately show ?thesis using ins by(fastforce intro!: exI)
  next
    case False
    with IH2 len call cs obtain pc' loc' stk'
      where ins: "pc' < length (compE2 i)" "compE2 i ! pc' = Invoke M' (length vs)"
      and exec: "τExec_mover_a P t i h (stk, loc, pc, None) (rev vs @ Addr a # stk', loc', pc', None)"
      and bisim': "P,i,h  (i', xs)  (rev vs @ Addr a # stk', loc', pc', None)" by fastforce
    from bisim' have "P,Ai := e,h  (Val vi' := e, xs)  ((rev vs @ Addr a # stk') @ [v], loc', length (compE2 A) + pc', None)"
      by(rule bisim1_bisims1.bisim1AAss2)
    with AAss_τExecrI2[OF exec, of A e v] ins False show ?thesis by(auto intro!: exI)
  qed
next
  case (bisim1AAss3 e n e' xs stk loc pc A i v v')
  then obtain pc' loc' stk' where pc': "pc' < length (compE2 e)" "compE2 e ! pc' = Invoke M' (length vs)"
    and exec: "τExec_mover_a P t e h (stk, loc, pc, None) (rev vs @ Addr a # stk', loc', pc', None)"
    and bisim': "P,e,h  (e', xs)  (rev vs @ Addr a # stk', loc', pc', None)" by fastforce
  from exec have "τExec_mover_a P t (Ai:=e) h (stk @ [v', v], loc, length (compE2 A) + length (compE2 i) + pc, None)
                                       ((rev vs @ Addr a # stk') @ [v', v], loc', length (compE2 A) + length (compE2 i) + pc', None)"
    by(rule AAss_τExecrI3)
  moreover from bisim'
  have "P,Ai := e,h  (Val vVal v' := e', xs)  ((rev vs @ Addr a # stk') @ [v', v], loc', length (compE2 A) + length (compE2 i) + pc', None)"
    by(rule bisim1_bisims1.bisim1AAss3)
  ultimately show ?case using pc' by(fastforce intro!: exI)
next
  case bisim1AAss4 thus ?case by simp
next
  case bisim1ALength thus ?case
    by(auto)(fastforce intro: bisim1_bisims1.bisim1ALength elim!: ALength_τExecrI intro!: exI)
next
  case bisim1FAcc thus ?case
    by(auto)(fastforce intro: bisim1_bisims1.bisim1FAcc elim!: FAcc_τExecrI intro!: exI)
next
  case (bisim1FAss1 e n e' xs stk loc pc e2 F D)
  note IH1 = call1 e' = (a, M', vs); n + max_vars e'  length xs; ¬ contains_insync e  ?concl e n e' xs pc stk loc
  note IH2 = xs. call1 e2 = (a, M', vs); n + max_vars e2  length xs; ¬ contains_insync e2  ?concl e2 n e2 xs 0 [] xs
  note call = ‹call1 (e'F{D} := e2) = (a, M', vs)
  note len = n + max_vars (e'F{D} := e2)  length xs
  note bisim1 = P,e,h  (e', xs)  (stk, loc, pc, None)
  note cs = ¬ contains_insync (eF{D} := e2)
  show ?case
  proof(cases "is_val e'")
    case True
    then obtain v where [simp]: "e' = Val v" by auto
    from bisim1 have "τExec_mover_a P t e h (stk, loc, pc, None) ([v], loc, length (compE2 e), None)"
      and [simp]: "xs = loc" by(auto dest!: bisim1Val2D1)
    hence "τExec_mover_a P t (eF{D} := e2) h (stk, loc, pc, None) ([v], loc, length (compE2 e), None)"
      by-(rule FAss_τExecrI1)
    also from call IH2[of loc] len cs obtain pc' stk' loc'
      where exec: "τExec_mover_a P t e2 h ([], xs, 0, None) (rev vs @ Addr a # stk', loc', pc', None)"
      and ins: "compE2 e2 ! pc' = Invoke M' (length vs)" "pc' < length (compE2 e2)"
      and bisim': "P,e2,h  (e2, xs)  (rev vs @ Addr a # stk', loc', pc', None)" by auto
    from FAss_τExecrI2[OF exec, of e F D v]
    have "τExec_mover_a P t (eF{D} := e2) h ([v], loc, length (compE2 e), None) (rev vs @ Addr a # (stk' @ [v]), loc', length (compE2 e) + pc', None)" by simp
    also (rtranclp_trans) from bisim'
    have "P,eF{D} := e2,h  (Val vF{D} := e2, xs)  ((rev vs @ Addr a # stk') @ [v], loc', length (compE2 e) + pc', None)"
      by(rule bisim1FAss2)
    ultimately show ?thesis using ins by fastforce
  next
    case False with IH1 len False call cs show ?thesis
      by(clarsimp)(fastforce intro: bisim1_bisims1.bisim1FAss1 elim!: FAss_τExecrI1 intro!: exI)
  qed
next
  case (bisim1FAss2 e2 n e' xs stk loc pc e F D v)
  then obtain pc' loc' stk' where pc': "pc' < length (compE2 e2)" "compE2 e2 ! pc' = Invoke M' (length vs)"
    and exec: "τExec_mover_a P t e2 h (stk, loc, pc, None) (rev vs @ Addr a # stk', loc', pc', None)"
    and bisim': "P,e2,h  (e', xs)  (rev vs @ Addr a # stk', loc', pc', None)" by fastforce
  from exec have "τExec_mover_a P t (eF{D} := e2) h (stk @ [v], loc, length (compE2 e) + pc, None)
                                       ((rev vs @ Addr a # stk') @ [v], loc', length (compE2 e) + pc', None)"
    by(rule FAss_τExecrI2)
  moreover from bisim'
  have "P,eF{D} := e2,h  (Val vF{D} := e', xs)  ((rev vs @ Addr a # stk') @ [v], loc', length (compE2 e) + pc', None)"
    by(rule bisim1_bisims1.bisim1FAss2)
  ultimately show ?case using pc' by(fastforce)
next
  case bisim1FAss3 thus ?case by simp
next
  case (bisim1CAS1 e1 n e' xs stk loc pc e2 e3 D F)
  note IH1 = call1 e' = (a, M', vs); n + max_vars e'  length xs; ¬ contains_insync e1   ?concl e1 n e' xs pc stk loc
  note IH2 = xs. call1 e2 = (a, M', vs); n + max_vars e2  length xs; ¬ contains_insync e2  ?concl e2 n e2 xs 0 [] xs
  note IH3 = xs. call1 e3 = (a, M', vs); n + max_vars e3  length xs; ¬ contains_insync e3  ?concl e3 n e3 xs 0 [] xs
  note call = ‹call1 _ = (a, M', vs)
  note len = n + max_vars _  length xs
  note bisim1 = P,e1,h  (e', xs)  (stk, loc, pc, None)
  note bisim2 = P,e2,h  (e2, loc)  ([], loc, 0, None)
  note cs = ¬ contains_insync _
  show ?case
  proof(cases "is_val e'")
    case True
    then obtain v where [simp]: "e' = Val v" by auto
    from bisim1 have "τExec_mover_a P t e1 h (stk, loc, pc, None) ([v], loc, length (compE2 e1), None)"
      and [simp]: "xs = loc" by(auto dest!: bisim1Val2D1)
    hence exec: "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h (stk, loc, pc, None) ([v], loc, length (compE2 e1), None)"
      by-(rule CAS_τExecrI1)
    show ?thesis
    proof(cases "is_val e2")
      case True
      then obtain v' where [simp]: "e2 = Val v'" by auto
      note exec also from bisim2
      have "τExec_mover_a P t e2 h ([], loc, 0, None) ([v'], loc, length (compE2 e2), None)"
        by(auto dest!: bisim1Val2D1)
      from CAS_τExecrI2[OF this, of e1 D F e3]
      have "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h ([v], loc, length (compE2 e1), None) ([v', v], loc, length (compE2 e1) + length (compE2 e2), None)" by simp
      also (rtranclp_trans) from call IH3[of loc] len cs obtain pc' stk' loc'
        where exec: "τExec_mover_a P t e3 h ([], loc, 0, None) (rev vs @ Addr a # stk', loc', pc', None)"
        and ins: "compE2 e3 ! pc' = Invoke M' (length vs)" "pc' < length (compE2 e3)"
        and bisim': "P,e3,h  (e3, loc)  (rev vs @ Addr a # stk', loc', pc', None)" by auto
      from CAS_τExecrI3[OF exec, of e1 D F e2 v' v]
      have "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h ([v', v], loc, length (compE2 e1) + length (compE2 e2), None)
                        ((rev vs @ Addr a # stk') @ [v', v], loc', length (compE2 e1) + length (compE2 e2) + pc', None)" by simp
      also (rtranclp_trans) from bisim'
      have "P,e1∙compareAndSwap(DF, e2, e3),h  (Val v∙compareAndSwap(DF, Val v', e3), xs)  ((rev vs @ Addr a # stk') @ [v', v], loc', length (compE2 e1) + length (compE2 e2) + pc', None)"
        by - (rule bisim1CAS3, simp)
      ultimately show ?thesis using ins by fastforce
    next
      case False
      note exec also from False call IH2[of loc] len cs obtain pc' stk' loc'
        where exec: "τExec_mover_a P t e2 h ([], xs, 0, None) (rev vs @ Addr a # stk', loc', pc', None)"
        and ins: "compE2 e2 ! pc' = Invoke M' (length vs)" "pc' < length (compE2 e2)"
        and bisim': "P,e2,h  (e2, xs)  (rev vs @ Addr a # stk', loc', pc', None)" by auto
      from CAS_τExecrI2[OF exec, of e1 D F e3 v]
      have "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h ([v], loc, length (compE2 e1), None) (rev vs @ Addr a # (stk' @ [v]), loc', length (compE2 e1) + pc', None)" by simp
      also (rtranclp_trans) from bisim'
      have "P,e1∙compareAndSwap(DF, e2, e3),h  (Val v∙compareAndSwap(DF, e2, e3), xs)  ((rev vs @ Addr a # stk') @ [v], loc', length (compE2 e1) + pc', None)"
        by(rule bisim1CAS2)
      ultimately show ?thesis using ins False by(fastforce intro!: exI)
    qed
  next
    case False with IH1 len False call cs show ?thesis
      by(clarsimp)(fastforce intro: bisim1_bisims1.bisim1CAS1 elim!: CAS_τExecrI1 intro!: exI)
  qed
next
  case (bisim1CAS2 e2 n e2' xs stk loc pc e1 e3 D F v)
  note IH2 = call1 e2' = (a, M', vs); n + max_vars e2'  length xs; ¬ contains_insync e2  ?concl e2 n e2' xs pc stk loc
  note IH3 = xs. call1 e3 = (a, M', vs); n + max_vars e3  length xs; ¬ contains_insync e3  ?concl e3 n e3 xs 0 [] xs
  note call = ‹call1 _ = (a, M', vs)
  note len = n + max_vars _  length xs
  note bisim2 = P,e2,h  (e2', xs)  (stk, loc, pc, None)
  note cs = ¬ contains_insync _
  show ?case
  proof(cases "is_val e2'")
    case True
    then obtain v' where [simp]: "e2' = Val v'" by auto
    from bisim2 have exec: "τExec_mover_a P t e2 h (stk, loc, pc, None) ([v'], loc, length (compE2 e2), None)"
      and [simp]: "xs = loc" by(auto dest!: bisim1Val2D1)
    from CAS_τExecrI2[OF exec, of e1 D F e3 v]
    have "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h (stk @ [v], loc, length (compE2 e1) + pc, None) ([v', v], loc, length (compE2 e1) + length (compE2 e2), None)" by simp
    also from call IH3[of loc] len cs obtain pc' stk' loc'
      where exec: "τExec_mover_a P t e3 h ([], xs, 0, None) (rev vs @ Addr a # stk', loc', pc', None)"
      and ins: "compE2 e3 ! pc' = Invoke M' (length vs)" "pc' < length (compE2 e3)"
      and bisim': "P,e3,h  (e3, xs)  (rev vs @ Addr a # stk', loc', pc', None)" by auto
    from CAS_τExecrI3[OF exec, of e1 D F e2 v' v]
    have "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h ([v', v], loc, length (compE2 e1) + length (compE2 e2), None)
                       ((rev vs @ Addr a # stk') @ [v', v], loc', length (compE2 e1) + length (compE2 e2) + pc', None)" by simp
    also (rtranclp_trans) from bisim'
    have "P,e1∙compareAndSwap(DF, e2, e3),h  (Val v∙compareAndSwap(DF, Val v', e3), xs)  ((rev vs @ Addr a # stk') @ [v', v], loc', length (compE2 e1) + length (compE2 e2) + pc', None)"
      by(rule bisim1CAS3)
    ultimately show ?thesis using ins by(fastforce intro!: exI)
  next
    case False
    with IH2 len call cs obtain pc' loc' stk'
      where ins: "pc' < length (compE2 e2)" "compE2 e2 ! pc' = Invoke M' (length vs)"
      and exec: "τExec_mover_a P t e2 h (stk, loc, pc, None) (rev vs @ Addr a # stk', loc', pc', None)"
      and bisim': "P,e2,h  (e2', xs)  (rev vs @ Addr a # stk', loc', pc', None)" by fastforce
    from bisim' have "P,e1∙compareAndSwap(DF, e2, e3),h  (Val v∙compareAndSwap(DF, e2', e3), xs)  ((rev vs @ Addr a # stk') @ [v], loc', length (compE2 e1) + pc', None)"
      by(rule bisim1_bisims1.bisim1CAS2)
    with CAS_τExecrI2[OF exec, of e1 D F e3 v] ins False show ?thesis by(auto intro!: exI)
  qed
next
  case (bisim1CAS3 e3 n e3' xs stk loc pc e1 e2 D F v v')
  then obtain pc' loc' stk' where pc': "pc' < length (compE2 e3)" "compE2 e3 ! pc' = Invoke M' (length vs)"
    and exec: "τExec_mover_a P t e3 h (stk, loc, pc, None) (rev vs @ Addr a # stk', loc', pc', None)"
    and bisim': "P,e3,h  (e3', xs)  (rev vs @ Addr a # stk', loc', pc', None)" by fastforce
  from exec have "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h (stk @ [v', v], loc, length (compE2 e1) + length (compE2 e2) + pc, None)
                                    ((rev vs @ Addr a # stk') @ [v', v], loc', length (compE2 e1) + length (compE2 e2) + pc', None)"
    by(rule CAS_τExecrI3)
  moreover from bisim'
  have "P,e1∙compareAndSwap(DF, e2, e3),h  (Val v∙compareAndSwap(DF, Val v', e3'), xs)  ((rev vs @ Addr a # stk') @ [v', v], loc', length (compE2 e1) + length (compE2 e2) + pc', None)"
    by(rule bisim1_bisims1.bisim1CAS3)
  ultimately show ?case using pc' by(fastforce intro!: exI)
next
  case (bisim1Call1 obj n obj' xs stk loc pc ps M)
  note IH1 = call1 obj' = (a, M', vs); n + max_vars obj'  length xs; ¬ contains_insync obj  ?concl obj n obj' xs pc stk loc
  note IH2 = xs. calls1 ps = (a, M', vs); n + max_varss ps  length xs; ¬ contains_insyncs ps  ?concls ps n ps xs 0 [] xs
  note len = n + max_vars (obj'M(ps))  length xs
  note bisim1 = P,obj,h  (obj', xs)  (stk, loc, pc, None)
  note call = ‹call1 (obj'M(ps)) = (a, M', vs)
  note cs = ¬ contains_insync (objM(ps))
  from call show ?case
  proof(cases rule: call1_callE)
    case CallObj
    hence "¬ is_val obj'" by auto
    with CallObj IH1 len cs show ?thesis
      by(clarsimp)(fastforce intro: bisim1_bisims1.bisim1Call1 elim!: Call_τExecrI1 intro!: exI)
  next
    case (CallParams v)
    with bisim1 have "τExec_mover_a P t obj h (stk, loc, pc, None) ([v], loc, length (compE2 obj), None)"
      and [simp]: "xs = loc" by(auto dest!: bisim1Val2D1)
    hence "τExec_mover_a P t (objM(ps)) h (stk, loc, pc, None) ([v], loc, length (compE2 obj), None)"
      by-(rule Call_τExecrI1)
    also from IH2[of loc] CallParams len cs obtain pc' stk' loc'
      where exec: "τExec_movesr_a P t ps h ([], loc, 0, None) (rev vs @ Addr a # stk', loc', pc', None)"
      and ins: "compEs2 ps ! pc' = Invoke M' (length vs)" "pc' < length (compEs2 ps)"
      and bisim': "P,ps,h  (ps, xs) [↔] (rev vs @ Addr a # stk',loc',pc',None)" by auto
    from Call_τExecrI2[OF exec, of obj M v]
    have "τExec_mover_a P t (objM(ps)) h ([v], loc, length (compE2 obj), None) (rev vs @ Addr a # (stk' @ [v]), loc', length (compE2 obj) + pc', None)" by simp
    also (rtranclp_trans)
    have "P,objM(ps),h  (Val vM(ps), xs)  ((rev vs @ Addr a # stk') @ [v], loc', length (compE2 obj) + pc', None)"
      using bisim' by(rule bisim1CallParams)
    ultimately show ?thesis using ins CallParams by fastforce
  next
    case [simp]: Call
    from bisim1 have "τExec_mover_a P t obj h (stk, loc, pc, None) ([Addr a], loc, length (compE2 obj), None)"
      and [simp]: "xs = loc" by(auto dest!: bisim1Val2D1)
    hence "τExec_mover_a P t (objM(ps)) h (stk, loc, pc, None) ([Addr a], loc, length (compE2 obj), None)"
      by-(rule Call_τExecrI1)
    also have "τExec_movesr_a P t ps h ([], xs, 0, None) (rev vs, xs, length (compEs2 ps), None)"
    proof(cases vs)
      case Nil with Call show ?thesis by(auto)
    next
      case Cons with Call bisims1_Val_τExec_moves[OF bisims1_refl[of P h "map Val vs" loc]]
      show ?thesis by(auto simp add: bsoks_def)
    qed
    from Call_τExecrI2[OF this, of obj M "Addr a"]
    have "τExec_mover_a P t (objM(ps)) h ([Addr a], loc, length (compE2 obj), None) (rev vs @ [Addr a], xs, length (compE2 obj) + length (compEs2 ps), None)" by simp
    also (rtranclp_trans)
    have "P,ps,h  (map Val vs,xs) [↔] (rev vs,xs,length (compEs2 ps),None)"
      by(rule bisims1_map_Val_append[OF bisims1Nil, simplified])(simp_all add: bsoks_def)
    hence "P,objM(ps),h  (addr aM(map Val vs), xs)  (rev vs @ [Addr a], xs, length (compE2 obj) + length (compEs2 ps), None)"
      by(rule bisim1CallParams)
    ultimately show ?thesis by fastforce
  qed
next
  case (bisim1CallParams ps n ps' xs stk loc pc obj M v)
  note IH2 = calls1 ps' = (a, M', vs); n + max_varss ps'  length xs; ¬ contains_insyncs ps  ?concls ps n ps' xs pc stk loc
  note bisim2 = P,ps,h  (ps', xs) [↔] (stk, loc, pc, None)
  note call = ‹call1 (Val vM(ps')) = (a, M', vs)
  note len = n + max_vars (Val vM(ps'))  length xs
  note cs = ¬ contains_insync (objM(ps))
  from call show ?case
  proof(cases rule: call1_callE)
    case CallObj thus ?thesis by simp
  next
    case (CallParams v')
    with IH2 len cs obtain pc' stk' loc'
      where exec: "τExec_movesr_a P t ps h (stk, loc, pc, None) (rev vs @ Addr a # stk', loc', pc', None)"
      and ins: "pc' < length (compEs2 ps)" "compEs2 ps ! pc' = Invoke M' (length vs)"
      and bisim': "P,ps,h  (ps', xs) [↔] (rev vs @ Addr a # stk',loc',pc',None)" by auto
    from exec have "τExec_mover_a P t (objM(ps)) h (stk @ [v], loc, length (compE2 obj) + pc, None)
                                ((rev vs @ Addr a # stk') @ [v], loc', length (compE2 obj) + pc', None)"
      by(rule Call_τExecrI2)
    moreover have "P,objM(ps),h  (Val vM(ps'), xs) 
                                  ((rev vs @ Addr a # stk') @ [v], loc', length (compE2 obj) + pc', None)"
      using bisim' by(rule bisim1_bisims1.bisim1CallParams)
    ultimately show ?thesis using ins by fastforce
  next
    case Call
    hence [simp]: "v = Addr a" "ps' = map Val vs" "M' = M" by simp_all
    have "xs = loc  τExec_movesr_a P t ps h (stk, loc, pc, None) (rev vs, loc, length (compEs2 ps), None)"
    proof(cases "pc < length (compEs2 ps)")
      case True with bisim2 show ?thesis by(auto dest: bisims1_Val_τExec_moves)
    next
      case False
      from bisim2 have "pc  length (compEs2 ps)" by(rule bisims1_pc_length_compEs2)
      with False have "pc = length (compEs2 ps)" by simp
      with bisim2 show ?thesis by(auto dest: bisims1_Val_length_compEs2D)
    qed
    then obtain [simp]: "xs = loc"
      and exec: "τExec_movesr_a P t ps h (stk, loc, pc, None) (rev vs, loc, length (compEs2 ps), None)" ..
    from exec have "τExec_mover_a P t (objM(ps)) h (stk @ [v], loc, length (compE2 obj) + pc, None)
                              (rev vs @ [v], loc, length (compE2 obj) + length (compEs2 ps), None)"
      by(rule Call_τExecrI2)
    moreover from bisim2 have len: "length ps = length ps'" by(auto dest: bisims1_lengthD)
    moreover have "P,ps,h  (map Val vs,xs) [↔] (rev vs,xs,length (compEs2 ps),None)" using len
      by-(rule bisims1_map_Val_append[OF bisims1Nil, simplified], simp_all)
    hence "P,objM(ps),h  (addr aM(map Val vs), xs)  (rev vs @ [Addr a], xs, length (compE2 obj) + length (compEs2 ps), None)" by(rule bisim1_bisims1.bisim1CallParams)
    ultimately show ?thesis by fastforce
  qed
next
  case bisim1BlockSome1 thus ?case by simp
next
  case bisim1BlockSome2 thus ?case by simp
next
  case (bisim1BlockSome4 e n e' xs stk loc pc V T v)
  then obtain pc' loc' stk' where pc': "pc' < length (compE2 e)" "compE2 e ! pc' = Invoke M' (length vs)"
    and exec: "τExec_mover_a P t e h (stk, loc, pc, None) (rev vs @ Addr a # stk', loc', pc', None)"
    and bisim': "P,e,h  (e', xs)  (rev vs @ Addr a # stk', loc', pc', None)" by auto
  note Block_τExecrI_Some[OF exec, of V T v]
  moreover from bisim' have "P,{V:T=v; e},h  ({V:T=None; e'}, xs)  (rev vs @ Addr a # stk', loc', Suc (Suc pc'), None)"
    by(rule bisim1_bisims1.bisim1BlockSome4)
  ultimately show ?case using pc' by fastforce
next  
 case (bisim1BlockNone e n e' xs stk loc pc V T)
  then obtain pc' loc' stk' where pc': "pc' < length (compE2 e)" "compE2 e ! pc' = Invoke M' (length vs)"
    and exec: "τExec_mover_a P t e h (stk, loc, pc, None) (rev vs @ Addr a # stk', loc', pc', None)"
    and bisim': "P,e,h  (e', xs)  (rev vs @ Addr a # stk', loc', pc', None)" by auto
  note Block_τExecrI_None[OF exec, of V T]
  moreover from bisim' have "P,{V:T=None; e},h  ({V:T=None; e'}, xs)  (rev vs @ Addr a # stk', loc', pc', None)"
    by(rule bisim1_bisims1.bisim1BlockNone)
  ultimately show ?case using pc' by fastforce
next
  case bisim1Sync1 thus ?case
    by (auto)(fastforce intro: bisim1_bisims1.bisim1Sync1 elim!: Sync_τExecrI intro!: exI)
next
  case bisim1Sync2 thus ?case by simp
next
  case bisim1Sync3 thus ?case by simp
next
  case bisim1Sync4 thus ?case
    by (auto)(fastforce intro: bisim1_bisims1.bisim1Sync4 elim!: Insync_τExecrI intro!: exI)
next
  case bisim1Sync5 thus ?case by simp
next
  case bisim1Sync6 thus ?case by simp
next
  case bisim1Sync7 thus ?case by simp
next
  case bisim1Sync8 thus ?case by simp
next
  case bisim1Sync9 thus ?case by simp
next
  case bisim1InSync thus ?case by simp
next
  case bisim1Seq1 thus ?case
    by (auto)(fastforce intro: bisim1_bisims1.bisim1Seq1 elim!: Seq_τExecrI1 intro!: exI)
next
  case (bisim1Seq2 e2 n e' xs stk loc pc e1)
  then obtain pc' loc' stk' where pc': "pc' < length (compE2 e2)" "compE2 e2 ! pc' = Invoke M' (length vs)"
    and exec: "τExec_mover_a P t e2 h (stk, loc, pc, None) (rev vs @ Addr a # stk', loc', pc', None)"
    and bisim': "P,e2,h  (e', xs)  (rev vs @ Addr a # stk', loc', pc', None)" by auto
  from Seq_τExecrI2[OF exec, of e1] pc' bisim'
  show ?case by(fastforce intro: bisim1_bisims1.bisim1Seq2 intro!: exI)
next
  case bisim1Cond1 thus ?case
    by (auto)(fastforce intro: bisim1_bisims1.bisim1Cond1 elim!: Cond_τExecrI1 intro!: exI)+
next
  case (bisim1CondThen e1 n e' xs stk loc pc e e2)
  then obtain pc' loc' stk' where pc': "pc' < length (compE2 e1)" "compE2 e1 ! pc' = Invoke M' (length vs)"
    and exec: "τExec_mover_a P t e1 h (stk, loc, pc, None) (rev vs @ Addr a # stk', loc', pc', None)"
    and bisim': "P,e1,h  (e', xs)  (rev vs @ Addr a # stk', loc', pc', None)" by auto
  from Cond_τExecrI2[OF exec] pc' bisim' show ?case
    by(fastforce intro: bisim1_bisims1.bisim1CondThen intro!: exI)
next
  case (bisim1CondElse e2 n e' xs stk loc pc e e1)
  then obtain pc' loc' stk' where pc': "pc' < length (compE2 e2)" "compE2 e2 ! pc' = Invoke M' (length vs)"
    and exec: "τExec_mover_a P t e2 h (stk, loc, pc, None) (rev vs @ Addr a # stk', loc', pc', None)"
    and bisim': "P,e2,h  (e', xs)  (rev vs @ Addr a # stk', loc', pc', None)" by auto
  from Cond_τExecrI3[OF exec] pc' bisim' show ?case
    by (fastforce intro: bisim1_bisims1.bisim1CondElse intro!: exI)
next
  case bisim1While1 thus ?case by simp
next
  case bisim1While3 thus ?case
    by (auto)(fastforce intro: bisim1_bisims1.bisim1While3 elim!: While_τExecrI1 intro!: exI)+
next
  case bisim1While4 thus ?case
    by (auto)(fastforce intro!: While_τExecrI2 bisim1_bisims1.bisim1While4 exI)+
next
  case bisim1While6 thus ?case by simp
next
  case bisim1While7 thus ?case by simp
next
  case bisim1Throw1 thus ?case
    by (auto)(fastforce intro!: exI bisim1_bisims1.bisim1Throw1 elim!: Throw_τExecrI)+
next
  case bisim1Try thus ?case
    by (auto)(fastforce intro: bisim1_bisims1.bisim1Try elim!: Try_τExecrI1 intro!: exI)+
next
  case (bisim1TryCatch1 e n a' xs stk loc pc C' C e2 V)
  note IH2 = xs. call1 e2 = (a, M', vs); Suc n + max_vars e2  length xs; ¬ contains_insync e2   ?concl e2 (Suc V) e2 xs 0 [] xs
  note bisim1 = P,e,h  (Throw a', xs)  (stk, loc, pc, a')
  note bisim2 = xs. P,e2,h  (e2, xs)  ([], xs, 0, None)
  note len = n + max_vars {V:Class C=None; e2}  length (xs[V := Addr a'])
  note cs = ¬ contains_insync (try e catch(C V) e2)
  from bisim1 have [simp]: "xs = loc" by(auto dest: bisim1_ThrowD)
  from len have "τExec_mover_a P t (try e catch(C V) e2) h ([Addr a'], loc, Suc (length (compE2 e)), None) ([], loc[V := Addr a'], Suc (Suc (length (compE2 e))), None)"
    by -(rule τExecr1step,auto simp add: exec_move_def intro: τmove2_τmoves2.intros exec_instr)
  also from IH2[of "loc[V := Addr a']"] len ‹call1 {V:Class C=None; e2} = (a, M', vs) cs
  obtain pc' loc' stk'
    where exec: "τExec_mover_a P t e2 h ([], loc[V := Addr a'], 0, None) (rev vs @ Addr a # stk', loc', pc', None)"
    and ins: "pc' < length (compE2 e2)" "compE2 e2 ! pc' = Invoke M' (length vs)"
    and bisim': "P,e2,h  (e2, loc[V := Addr a'])  (rev vs @ Addr a # stk', loc', pc', None)" by auto
  from Try_τExecrI2[OF exec, of e C V]
  have "τExec_mover_a P t (try e catch(C V) e2) h ([], loc[V := Addr a'], Suc (Suc (length (compE2 e))), None) (rev vs @ Addr a # stk', loc', Suc (Suc (length (compE2 e) + pc')), None)" by simp
  also from bisim'
  have "P,try e catch(C V) e2,h  ({V:Class C=None; e2}, loc[V := Addr a'])  (rev vs @ Addr a # stk', loc', (Suc (Suc (length (compE2 e) + pc'))), None)"
    by(rule bisim1TryCatch2)
  ultimately show ?case using ins by fastforce
next
  case bisim1TryCatch2 thus ?case
    by (auto)(fastforce intro!: Try_τExecrI2 bisim1_bisims1.bisim1TryCatch2 exI)+
next
  case bisims1Nil thus ?case by simp
next
  case (bisims1List1 e n e' xs stk loc pc es)
  note IH1 = call1 e' = (a, M', vs); n + max_vars e'  length xs; ¬ contains_insync e  ?concl e n e' xs pc stk loc
  note IH2 = xs. calls1 es = (a, M', vs); n + max_varss es  length xs; ¬ contains_insyncs es  ?concls es n es xs 0 [] xs
  note bisim1 = P,e,h  (e', xs)  (stk, loc, pc, None)
  note call = ‹calls1 (e' # es) = (a, M', vs)
  note len = n + max_varss (e' # es)  length xs
  note cs = ¬ contains_insyncs (e # es)
  show ?case
  proof(cases "is_val e'")
    case True
    then obtain v where [simp]: "e' = Val v" by auto
    with bisim1 have "τExec_mover_a P t e h (stk, loc, pc, None) ([v], loc, length (compE2 e), None)"
      and [simp]: "xs = loc" by(auto dest!: bisim1Val2D1)
    hence "τExec_movesr_a P t (e # es) h (stk, loc, pc, None) ([v], loc, length (compE2 e), None)"
      by-(rule τExec_mover_τExec_movesr)
    also from call IH2[of loc] len cs obtain pc' stk' loc'
      where exec: "τExec_movesr_a P t es h ([], xs, 0, None) (rev vs @ Addr a # stk', loc', pc', None)"
      and ins: "compEs2 es ! pc' = Invoke M' (length vs)" "pc' < length (compEs2 es)"
      and bisim': "P,es,h  (es, xs) [↔] (rev vs @ Addr a # stk',loc',pc',None)" by auto
    from append_τExec_movesr[OF _ exec, of "[v]" "[e]"]
    have "τExec_movesr_a P t (e # es) h ([v], loc, length (compE2 e), None) (rev vs @ Addr a # (stk' @ [v]), loc', length (compE2 e) + pc', None)"
      by simp
    also (rtranclp_trans) from bisim'
    have "P,e # es,h  (Val v # es, xs) [↔]
                         ((rev vs @ Addr a # stk') @ [v],loc',length (compE2 e) + pc',None)"
      by(rule bisim1_bisims1.bisims1List2)
    ultimately show ?thesis using ins by fastforce
  next
    case False
    with call IH1 len cs show ?thesis
      by (auto)(fastforce intro!: τExec_mover_τExec_movesr bisim1_bisims1.bisims1List1 exI)+
  qed
next
  case (bisims1List2 es n es' xs stk loc pc e v)
  then obtain pc' stk' loc' where pc': "pc' < length (compEs2 es)" "compEs2 es ! pc' = Invoke M' (length vs)"
    and exec: "τExec_movesr_a P t es h (stk, loc, pc, None) (rev vs @ Addr a # stk', loc', pc', None)"
    and bisim': "P,es,h  (es', xs) [↔] (rev vs @ Addr a # stk', loc', pc', None)" by auto
  note append_τExec_movesr[OF _ exec, of "[v]" "[e]"]
  moreover from bisim'
  have "P,e#es,h  (Val v# es', xs) [↔] ((rev vs @ Addr a # stk') @ [v],loc',length (compE2 e) + pc',None)"
    by(rule bisim1_bisims1.bisims1List2)
  ultimately show ?case using pc' by fastforce
qed 

lemma fixes P :: "'addr J1_prog"
  shows bisim1_inline_call_Val:
  " P,e,h  (e', xs)  (stk, loc, pc, None); call1 e' = (a, M, vs);
     compE2 e ! pc = Invoke M n0 
     length stk  Suc (length vs)  n0 = length vs 
       P,e,h  (inline_call (Val v) e', xs)  (v # drop (Suc (length vs)) stk, loc, Suc pc, None)"
  (is " _; _; _   ?concl e n e' xs pc stk loc")

  and bisims1_inline_calls_Val:
  " P,es,h  (es',xs) [↔] (stk,loc,pc,None); calls1 es' = (a, M, vs);
     compEs2 es ! pc = Invoke M n0 
     length stk  Suc (length vs)  n0 = length vs 
       P,es,h  (inline_calls (Val v) es', xs) [↔] (v # drop (Suc (length vs)) stk,loc,Suc pc,None)"
  (is " _; _; _   ?concls es n es' xs pc stk loc")
proof(induct "(e', xs)" "(stk, loc, pc, None :: 'addr option)"
    and "(es', xs)" "(stk, loc, pc, None :: 'addr option)"
    arbitrary: e' xs stk loc pc and es' xs stk loc pc rule: bisim1_bisims1.inducts)
  case bisim1Val2 thus ?case by simp
next
  case bisim1New thus ?case by simp
next
  case bisim1NewArray thus ?case
    by(auto split: if_split_asm dest: bisim1_pc_length_compE2 intro: bisim1_bisims1.bisim1NewArray)
next
  case bisim1Cast thus ?case
    by(auto split: if_split_asm dest: bisim1_pc_length_compE2 intro: bisim1_bisims1.bisim1Cast)
next
  case bisim1InstanceOf thus ?case
    by(auto split: if_split_asm dest: bisim1_pc_length_compE2 intro: bisim1_bisims1.bisim1InstanceOf)
next
  case bisim1Val thus ?case by simp
next
  case bisim1Var thus ?case by simp
next
  case (bisim1BinOp1 e1 e' xs stk loc pc bop e2)
  note IH1 = call1 e' = (a, M, vs); compE2 e1 ! pc = Invoke M n0   ?concl e1 n e' xs pc stk loc
  note bisim1 = P,e1,h  (e', xs)  (stk, loc, pc, None)
  note call = ‹call1 (e' «bop» e2) = (a, M, vs)
  note ins = ‹compE2 (e1 «bop» e2) ! pc = Invoke M n0
  show ?case
  proof(cases "is_val e'")
    case False
    with bisim1 call have "pc < length (compE2 e1)" by(auto intro: bisim1_call_pcD)
    with call ins False IH1 show ?thesis
      by(auto intro: bisim1_bisims1.bisim1BinOp1)
  next
    case True
    then obtain v where [simp]: "e' = Val v" by auto
    from bisim1 have "pc  length (compE2 e1)" by(auto dest: bisim1_pc_length_compE2)
    moreover {
      assume pc: "pc < length (compE2 e1)"
      with bisim1 ins have False by(auto dest: bisim_Val_pc_not_Invoke simp add: nth_append) }
    ultimately have [simp]: "pc = length (compE2 e1)" by(cases "pc < length (compE2 e1)") auto
    with ins have False by(simp)
    thus ?thesis ..
  qed
next
  case (bisim1BinOp2 e2 e' xs stk loc pc e1 bop v1)
  note IH2 = call1 e' = (a, M, vs); compE2 e2 ! pc = Invoke M n0  ?concl e2 n e' xs pc stk loc
  note bisim2 = P,e2,h  (e', xs)  (stk, loc, pc, None)
  note call = ‹call1 (Val v1 «bop» e') = (a, M, vs)
  note ins = ‹compE2 (e1 «bop» e2) ! (length (compE2 e1) + pc) = Invoke M n0
  from call bisim2 have pc: "pc < length (compE2 e2)" by(auto intro: bisim1_call_pcD)
  with ins have ins': "compE2 e2 ! pc = Invoke M n0" by(simp)
  from IH2 ins' pc call show ?case by(auto dest: bisim1_bisims1.bisim1BinOp2)
next
  case bisim1LAss1 thus ?case
    by(auto split: if_split_asm dest: bisim1_pc_length_compE2 intro: bisim1_bisims1.bisim1LAss1)
next
  case bisim1LAss2 thus ?case by simp
next
  case (bisim1AAcc1 A a' xs stk loc pc i)
  note IH1 = call1 a' = (a, M, vs); compE2 A ! pc = Invoke M n0  ?concl A n a' xs pc stk loc
  note bisim1 = P,A,h  (a', xs)  (stk, loc, pc, None)
  note call = ‹call1 (a'i) = (a, M, vs)
  note ins = ‹compE2 (Ai) ! pc = Invoke M n0
  show ?case
  proof(cases "is_val a'")
    case False
    with bisim1 call have "pc < length (compE2 A)" by(auto intro: bisim1_call_pcD)
    with call ins False IH1 show ?thesis
      by(auto intro: bisim1_bisims1.bisim1AAcc1)
  next
    case True
    then obtain v where [simp]: "a' = Val v" by auto
    from bisim1 have "pc  length (compE2 A)" by(auto dest: bisim1_pc_length_compE2)
    moreover {
      assume pc: "pc < length (compE2 A)"
      with bisim1 ins have False by(auto dest: bisim_Val_pc_not_Invoke simp add: nth_append) }
    ultimately have [simp]: "pc = length (compE2 A)" by(cases "pc < length (compE2 A)") auto
    with ins have False by(simp)
    thus ?thesis ..
  qed
next
  case (bisim1AAcc2 i i' xs stk loc pc A v)
  note IH2 = call1 i' = (a, M, vs); compE2 i ! pc = Invoke M n0  ?concl i n i' xs pc stk loc
  note bisim2 = P,i,h  (i', xs)  (stk, loc, pc, None)
  note call = ‹call1 (Val vi') = (a, M, vs)
  note ins = ‹compE2 (Ai) ! (length (compE2 A) + pc) = Invoke M n0
  from call bisim2 have pc: "pc < length (compE2 i)" by(auto intro: bisim1_call_pcD)
  with ins have ins': "compE2 i ! pc = Invoke M n0" by(simp)
  from IH2 ins' pc call show ?case
    by(auto dest: bisim1_bisims1.bisim1AAcc2)
next
  case (bisim1AAss1 A a' xs stk loc pc i e)
  note IH1 = call1 a' = (a, M, vs); compE2 A ! pc = Invoke M n0  ?concl A n a' xs pc stk loc
  note bisim1 = P,A,h  (a', xs)  (stk, loc, pc, None)
  note call = ‹call1 (a'i := e) = (a, M, vs)
  note ins = ‹compE2 (Ai := e) ! pc = Invoke M n0
  show ?case
  proof(cases "is_val a'")
    case False
    with bisim1 call have "pc < length (compE2 A)" by(auto intro: bisim1_call_pcD)
    with call ins False IH1 show ?thesis by(auto intro: bisim1_bisims1.bisim1AAss1)
  next
    case True
    then obtain v where [simp]: "a' = Val v" by auto
    from bisim1 have "pc  length (compE2 A)" by(auto dest: bisim1_pc_length_compE2)
    moreover {
      assume pc: "pc < length (compE2 A)"
      with bisim1 ins have False by(auto dest: bisim_Val_pc_not_Invoke simp add: nth_append) }
    ultimately have [simp]: "pc = length (compE2 A)" by(cases "pc < length (compE2 A)") auto
    with ins have False by(simp)
    thus ?thesis ..
  qed
next
  case (bisim1AAss2 i i' xs stk loc pc A e v)
  note IH2 = call1 i' = (a, M, vs); compE2 i ! pc = Invoke M n0  ?concl i n i' xs pc stk loc
  note bisim2 = P,i,h  (i', xs)  (stk, loc, pc, None)
  note call = ‹call1 (Val vi' := e) = (a, M, vs)
  note ins = ‹compE2 (Ai := e) ! (length (compE2 A) + pc) = Invoke M n0
  show ?case
  proof(cases "is_val i'")
    case False
    with bisim2 call have pc: "pc < length (compE2 i)" by(auto intro: bisim1_call_pcD)
    with ins have ins': "compE2 i ! pc = Invoke M n0" by(simp)
    from IH2 ins' pc False call show ?thesis by(auto dest: bisim1_bisims1.bisim1AAss2)
  next
    case True
    then obtain v where [simp]: "i' = Val v" by auto
    from bisim2 have "pc  length (compE2 i)" by(auto dest: bisim1_pc_length_compE2)
    moreover {
      assume pc: "pc < length (compE2 i)"
      with bisim2 ins have False by(auto dest: bisim_Val_pc_not_Invoke simp add: nth_append) }
    ultimately have [simp]: "pc = length (compE2 i)" by(cases "pc < length (compE2 i)") auto
    with ins have False by(simp)
    thus ?thesis ..
  qed
next
  case (bisim1AAss3 e e' xs stk loc pc i A v v')
  note IH2 = call1 e' = (a, M, vs); compE2 e ! pc = Invoke M n0  ?concl e n e' xs pc stk loc
  note bisim3 = P,e,h  (e', xs)  (stk, loc, pc, None)
  note call = ‹call1 (Val vVal v' := e') = (a, M, vs)
  note ins = ‹compE2 (iA := e) ! (length (compE2 i) + length (compE2 A) + pc) = Invoke M n0
  from call bisim3 have pc: "pc < length (compE2 e)" by(auto intro: bisim1_call_pcD)
  with ins have ins': "compE2 e ! pc = Invoke M n0" by(simp)
  from IH2 ins' pc call show ?case by(auto dest: bisim1_bisims1.bisim1AAss3)
next
  case bisim1AAss4 thus ?case by simp
next
  case bisim1ALength thus ?case
    by(auto split: if_split_asm dest: bisim1_pc_length_compE2 intro: bisim1_bisims1.bisim1ALength)
next
  case bisim1FAcc thus ?case
    by(auto split: if_split_asm dest: bisim1_pc_length_compE2 intro: bisim1_bisims1.bisim1FAcc)
next
  case (bisim1FAss1 e1 e' xs stk loc pc F D e2)
  note IH1 = call1 e' = (a, M, vs); compE2 e1 ! pc = Invoke M n0  ?concl e1 n e' xs pc stk loc
  note bisim1 = P,e1,h  (e', xs)  (stk, loc, pc, None)
  note call = ‹call1 (e'F{D} := e2) = (a, M, vs)
  note ins = ‹compE2 (e1F{D} := e2) ! pc = Invoke M n0
  show ?case
  proof(cases "is_val e'")
    case False
    with bisim1 call have "pc < length (compE2 e1)" by(auto intro: bisim1_call_pcD)
    with call ins False IH1 show ?thesis
      by(auto intro: bisim1_bisims1.bisim1FAss1)
  next
    case True
    then obtain v where [simp]: "e' = Val v" by auto
    from bisim1 have "pc  length (compE2 e1)" by(auto dest: bisim1_pc_length_compE2)
    moreover {
      assume pc: "pc < length (compE2 e1)"
      with bisim1 ins have False by(auto dest: bisim_Val_pc_not_Invoke simp add: nth_append) }
    ultimately have [simp]: "pc = length (compE2 e1)" by(cases "pc < length (compE2 e1)") auto
    with ins have False by(simp)
    thus ?thesis ..
  qed
next
  case (bisim1FAss2 e2 e' xs stk loc pc e1 F D v1)
  note IH2 = call1 e' = (a, M, vs); compE2 e2 ! pc = Invoke M n0  ?concl e2 n e' xs pc stk loc
  note bisim2 = P,e2,h  (e', xs)  (stk, loc, pc, None)
  note call = ‹call1 (Val v1F{D} := e') = (a, M, vs)
  note ins = ‹compE2 (e1F{D} := e2) ! (length (compE2 e1) + pc) = Invoke M n0
  from call bisim2 have pc: "pc < length (compE2 e2)" by(auto intro: bisim1_call_pcD)
  with ins have ins': "compE2 e2 ! pc = Invoke M n0" by(simp)
  from IH2 ins' pc call show ?case by(auto dest: bisim1_bisims1.bisim1FAss2)
next
  case bisim1FAss3 thus ?case by simp
next
  case (bisim1CAS1 e1 e' xs stk loc pc D F e2 E3)
  note IH1 = call1 e' = (a, M, vs); compE2 e1 ! pc = Invoke M n0  ?concl e1 n e' xs pc stk loc
  note bisim1 = P,e1,h  (e', xs)  (stk, loc, pc, None)
  note call = ‹call1 _ = (a, M, vs)
  note ins = ‹compE2 _ ! pc = Invoke M n0
  show ?case
  proof(cases "is_val e'")
    case False
    with bisim1 call have "pc < length (compE2 e1)" by(auto intro: bisim1_call_pcD)
    with call ins False IH1 show ?thesis by(auto intro: bisim1_bisims1.bisim1CAS1)
  next
    case True
    then obtain v where [simp]: "e' = Val v" by auto
    from bisim1 have "pc  length (compE2 e1)" by(auto dest: bisim1_pc_length_compE2)
    moreover {
      assume pc: "pc < length (compE2 e1)"
      with bisim1 ins have False by(auto dest: bisim_Val_pc_not_Invoke simp add: nth_append) }
    ultimately have [simp]: "pc = length (compE2 e1)" by(cases "pc < length (compE2 e1)") auto
    with ins have False by(simp)
    thus ?thesis ..
  qed
next
  case (bisim1CAS2 e2 e2' xs stk loc pc e1 D F e3 v)
  note IH2 = call1 e2' = (a, M, vs); compE2 e2 ! pc = Invoke M n0  ?concl e2 n e2' xs pc stk loc
  note bisim2 = P,e2,h  (e2', xs)  (stk, loc, pc, None)
  note call = ‹call1 _ = (a, M, vs)
  note ins = ‹compE2 _ ! (length (compE2 e1) + pc) = Invoke M n0
  show ?case
  proof(cases "is_val e2'")
    case False
    with bisim2 call have pc: "pc < length (compE2 e2)" by(auto intro: bisim1_call_pcD)
    with ins have ins': "compE2 e2 ! pc = Invoke M n0" by(simp)
    from IH2 ins' pc False call show ?thesis by(auto dest: bisim1_bisims1.bisim1CAS2)
  next
    case True
    then obtain v where [simp]: "e2' = Val v" by auto
    from bisim2 have "pc  length (compE2 e2)" by(auto dest: bisim1_pc_length_compE2)
    moreover {
      assume pc: "pc < length (compE2 e2)"
      with bisim2 ins have False by(auto dest: bisim_Val_pc_not_Invoke simp add: nth_append) }
    ultimately have [simp]: "pc = length (compE2 e2)" by(cases "pc < length (compE2 e2)") auto
    with ins have False by(simp)
    thus ?thesis ..
  qed
next
  case (bisim1CAS3 e3 e3' xs stk loc pc e1 D F e2 v v')
  note IH2 = call1 e3' = (a, M, vs); compE2 e3 ! pc = Invoke M n0  ?concl e3 n e3' xs pc stk loc
  note bisim3 = P,e3,h  (e3', xs)  (stk, loc, pc, None)
  note call = ‹call1 _ = (a, M, vs)
  note ins = ‹compE2 _ ! (length (compE2 e1) + length (compE2 e2) + pc) = Invoke M n0
  from call bisim3 have pc: "pc < length (compE2 e3)" by(auto intro: bisim1_call_pcD)
  with ins have ins': "compE2 e3 ! pc = Invoke M n0" by(simp)
  from IH2 ins' pc call show ?case by(auto dest: bisim1_bisims1.bisim1CAS3)
next
  case (bisim1Call1 obj obj' xs stk loc pc M' ps)
  note IH1 = call1 obj' = (a, M, vs); compE2 obj ! pc = Invoke M n0  ?concl obj n obj' xs pc stk loc
  note bisim1 = P,obj,h  (obj', xs)  (stk, loc, pc, None)
  note call = ‹call1 (obj'M'(ps)) = (a, M, vs)
  note ins = ‹compE2 (objM'(ps)) ! pc = Invoke M n0
  show ?case
  proof(cases "is_val obj'")
    case False
    with call bisim1 have "pc < length (compE2 obj)" by(auto intro: bisim1_call_pcD)
    with call False ins IH1 False show ?thesis
      by(auto intro: bisim1_bisims1.bisim1Call1)
  next
    case True
    then obtain v' where [simp]: "obj' = Val v'" by auto
    from bisim1 have "pc  length (compE2 obj)" by(auto dest: bisim1_pc_length_compE2)
    moreover {
      assume pc: "pc < length (compE2 obj)"
      with bisim1 ins have False by(auto dest: bisim_Val_pc_not_Invoke simp add: nth_append) }
    ultimately have [simp]: "pc = length (compE2 obj)" by(cases "pc < length (compE2 obj)") auto
    with ins have [simp]: "ps = []" "M' = M"
      by(auto simp add: nth_append split: if_split_asm)(auto simp add: neq_Nil_conv nth_append)
    from ins call have [simp]: "vs = []" by(auto split: if_split_asm)
    with bisim1 have [simp]: "stk = [v']" "xs = loc" by(auto dest: bisim1_pc_length_compE2D)
    from bisim1Val2[of "length (compE2 (objM([])))" "objM([])" P h v loc] call ins
    show ?thesis by(auto simp add: is_val_iff)
  qed
next
  case (bisim1CallParams ps ps' xs stk loc pc obj M' v')
  note IH2 = calls1 ps' = (a, M, vs); compEs2 ps ! pc = Invoke M n0  ?concls ps n ps' xs pc stk loc
  note bisim = P,ps,h  (ps', xs) [↔] (stk, loc, pc, None)
  note call = ‹call1 (Val v'M'(ps')) = (a, M, vs)
  note ins = ‹compE2 (objM'(ps)) ! (length (compE2 obj) + pc) = Invoke M n0
  from call show ?case
  proof(cases rule: call1_callE)
    case CallObj thus ?thesis by simp
  next
    case (CallParams v'')
    hence [simp]: "v'' = v'" and call': "calls1 ps' = (a, M, vs)" by simp_all
    from bisim call' have pc: "pc < length (compEs2 ps)" by(rule bisims1_calls_pcD)
    with ins have ins': "compEs2 ps ! pc = Invoke M n0" by(simp add: nth_append)
    with IH2 call' ins pc
    have "P,ps,h  (inline_calls (Val v) ps', xs)
                [↔] (v # drop (Suc (length vs)) stk, loc, Suc pc, None)"
      and len: "Suc (length vs)  length stk" and n0: "n0 = length vs" by auto
    hence "P,objM'(ps),h  (Val v'M'(inline_calls (Val v) ps'), xs)
                            ((v # drop (Suc (length vs)) stk) @ [v'], loc, length (compE2 obj) + Suc pc, None)"
      by-(rule bisim1_bisims1.bisim1CallParams)
    thus ?thesis using call' len n0 by(auto simp add: is_vals_conv)
  next
    case Call
    hence [simp]: "v' = Addr a" "M' = M" "ps' = map Val vs" by auto
    from bisim have "pc  length (compEs2 ps)" by(auto dest: bisims1_pc_length_compEs2)
    moreover {
      assume pc: "pc < length (compEs2 ps)"
      with bisim ins have False by(auto dest: bisims_Val_pc_not_Invoke simp add: nth_append) }
    ultimately have [simp]: "pc = length (compEs2 ps)" by(cases "pc < length (compEs2 ps)") auto
    from bisim have [simp]: "stk = rev vs" "xs = loc" by(auto dest: bisims1_Val_length_compEs2D)
    hence "P,objM(ps),h  (Val v, loc)  ([v], loc, length (compE2 (objM(ps))), None)" by-(rule bisim1Val2, simp)
    moreover from bisim have "length ps = length ps'" by(rule bisims1_lengthD)
    ultimately show ?thesis using ins by(auto)
  qed
next
  case bisim1BlockSome1 thus ?case by simp
next
  case bisim1BlockSome2 thus ?case by simp
next
  case bisim1BlockSome4 thus ?case
    by(auto intro: bisim1_bisims1.bisim1BlockSome4)
next
  case bisim1BlockNone thus ?case
    by(auto intro: bisim1_bisims1.bisim1BlockNone)
next
  case bisim1Sync1 thus ?case
    by(auto split: if_split_asm dest: bisim1_pc_length_compE2 intro: bisim1_bisims1.bisim1Sync1)
next
  case bisim1Sync2 thus ?case by simp
next
  case bisim1Sync3 thus ?case by simp
next
  case bisim1Sync4 thus ?case
    by(auto split: if_split_asm dest: bisim1_pc_length_compE2 bisim1_bisims1.bisim1Sync4)
next
  case bisim1Sync5 thus ?case by simp
next
  case bisim1Sync6 thus ?case by simp
next
  case bisim1Sync7 thus ?case by simp
next
  case bisim1Sync8 thus ?case by simp
next
  case bisim1Sync9 thus ?case by simp
next
  case bisim1InSync thus ?case by(simp)
next
  case bisim1Seq1 thus ?case
    by(auto split: if_split_asm dest: bisim1_pc_length_compE2 intro: bisim1_bisims1.bisim1Seq1)
next
  case bisim1Seq2 thus ?case
    by(auto split: if_split_asm dest: bisim1_pc_length_compE2)(fastforce dest: bisim1_bisims1.bisim1Seq2)
next
  case bisim1Cond1 thus ?case
    by(auto split: if_split_asm dest: bisim1_pc_length_compE2 intro: bisim1_bisims1.bisim1Cond1)
next
  case (bisim1CondThen e1 stk loc pc e e2 e' xs) thus ?case
    by(auto split: if_split_asm dest: bisim1_pc_length_compE2)
      (fastforce dest: bisim1_bisims1.bisim1CondThen[where e=e and ?e2.0=e2])
next
  case (bisim1CondElse e2 stk loc pc e e1 e' xs) thus ?case
    by(auto split: if_split_asm dest: bisim1_pc_length_compE2)
      (fastforce dest: bisim1_bisims1.bisim1CondElse[where e=e and ?e1.0=e1])
next
  case bisim1While1 thus ?case by simp
next
  case bisim1While3 thus ?case
    by(auto split: if_split_asm dest: bisim1_pc_length_compE2 intro: bisim1_bisims1.bisim1While3)
next
  case bisim1While4 thus ?case
    by(auto split: if_split_asm dest: bisim1_pc_length_compE2)(fastforce dest: bisim1_bisims1.bisim1While4)
next
  case bisim1While6 thus ?case by simp
next
  case bisim1While7 thus ?case by simp
next
  case bisim1Throw1 thus ?case
    by(auto split: if_split_asm dest: bisim1_pc_length_compE2 intro: bisim1_bisims1.bisim1Throw1)
next
  case bisim1Try thus ?case
    by(auto split: if_split_asm dest: bisim1_pc_length_compE2 intro: bisim1_bisims1.bisim1Try)
next
  case bisim1TryCatch1 thus ?case by simp
next
  case bisim1TryCatch2 thus ?case
    by(fastforce dest: bisim1_bisims1.bisim1TryCatch2)
next
  case bisims1Nil thus ?case by simp
next
  case (bisims1List1 e e' xs stk loc pc es)
  note IH1 = call1 e' = (a, M, vs); compE2 e ! pc = Invoke M n0  ?concl e n e' xs pc stk loc
  note bisim1 = P,e,h  (e', xs)  (stk, loc, pc, None)
  note call = ‹calls1 (e' # es) = (a, M, vs)
  note ins = ‹compEs2 (e # es) ! pc = Invoke M n0
  show ?case
  proof(cases "is_val e'")
    case False
    with bisim1 call have "pc < length (compE2 e)" by(auto intro: bisim1_call_pcD)
    with call ins False IH1 show ?thesis
      by(auto intro: bisim1_bisims1.bisims1List1)
  next
    case True
    then obtain v where [simp]: "e' = Val v" by auto
    from bisim1 have "pc  length (compE2 e)" by(auto dest: bisim1_pc_length_compE2)
    moreover {
      assume pc: "pc < length (compE2 e)"
      with bisim1 ins have False by(auto dest: bisim_Val_pc_not_Invoke simp add: nth_append) }
    ultimately have [simp]: "pc = length (compE2 e)" by(cases "pc < length (compE2 e)") auto
    with ins call have False by(cases es)(auto)
    thus ?thesis ..
  qed
next
  case (bisims1List2 es es' xs stk loc pc e v')
  note IH = calls1 es' = (a, M, vs); compEs2 es ! pc = Invoke M n0  ?concls es n es' xs pc stk loc
  note call = ‹calls1 (Val v' # es') = (a, M, vs)
  note bisim = P,es,h  (es', xs) [↔] (stk, loc, pc, None)
  note ins = ‹compEs2 (e # es) ! (length (compE2 e) + pc) = Invoke M n0
  from call have call': "calls1 es' = (a, M, vs)" by simp
  with bisim have pc: "pc < length (compEs2 es)" by(rule bisims1_calls_pcD)
  with ins have ins': "compEs2 es ! pc = Invoke M n0" by(simp add: nth_append)
  from IH call ins pc show ?case
    by(auto split: if_split_asm dest: bisim1_bisims1.bisims1List2)
qed

lemma bisim1_fv: "P,e,h  (e', xs)  s  fv e'  fv e"
  and bisims1_fvs: "P,es,h  (es', xs) [↔] s  fvs es'  fvs es"
apply(induct "(e', xs)" s and "(es', xs)" s arbitrary: e' xs and es' xs rule: bisim1_bisims1.inducts)
apply(auto)
done


lemma bisim1_syncvars: " P,e,h  (e', xs)  s; syncvars e   syncvars e'"
  and bisims1_syncvarss: " P,es,h  (es', xs) [↔] s; syncvarss es   syncvarss es'"
apply(induct "(e', xs)" s and "(es', xs)" s arbitrary: e' xs and es' xs rule: bisim1_bisims1.inducts)
apply(auto dest: bisim1_fv)
done

declare pcs_stack_xlift [simp]

lemma bisim1_Val_τred1r:
  " P, E, h  (e, xs)  ([v], loc, length (compE2 E), None); n + max_vars e  length xs;E n  
   τred1r P t h (e, xs) (Val v, loc)"

 and bisims1_Val_τReds1r:
  " P, Es, h  (es, xs) [↔] (rev vs, loc, length (compEs2 Es), None); n + max_varss es  length xs; ℬs Es n 
    τreds1r P t h (es, xs) (map Val vs, loc)"
proof(induct E n e xs stk"[v]" loc pc"length (compE2 E)" xcp"None::'addr option"
         and Es n es xs stk"rev vs" loc pc"length (compEs2 Es)" xcp"None::'addr option"
      arbitrary: v and vs rule: bisim1_bisims1_inducts_split)
  case bisim1BlockSome2 thus ?case by(simp (no_asm_use))
next
  case (bisim1BlockSome4 e n e' xs loc pc V T val)
  from ‹ℬ {V:T=val; e} n have [simp]: "n = V" and "ℬ e (Suc n)" by auto
  note len = n + max_vars {V:T=None; e'}  length xs
  hence V: "V < length xs" by simp
  from P,e,h  (e', xs)  ([v], loc, pc, None)
  have lenxs: "length xs = length loc" by(auto dest: bisim1_length_xs)
  note IH = pc = length (compE2 e); Suc n + max_vars e'  length xs;e (Suc n)
              τred1r P t h (e', xs) (Val v, loc)
  with len ‹Suc (Suc pc) = length (compE2 {V:T=val; e}) ‹ℬ e (Suc n)
  have "τred1r P t h (e', xs) (Val v, loc)" by(simp)
  hence "τred1r P t h ({V:T=None; e'}, xs) ({V:T=None; Val v}, loc)"
    by(rule Block_None_τred1r_xt)
  thus ?case using V lenxs by(auto elim!: rtranclp.rtrancl_into_rtrancl intro: Red1Block τmove1BlockRed)
next
  case (bisim1BlockNone e n e' xs loc V T)
  from ‹ℬ {V:T=None; e} n have [simp]: "n = V" and "ℬ e (Suc n)" by auto
  note len = n + max_vars {V:T=None; e'}  length xs
  hence V: "V < length xs" by simp
  from P,e,h  (e', xs)  ([v], loc, length (compE2 {V:T=None; e}), None)
  have lenxs: "length xs = length loc" by(auto dest: bisim1_length_xs)
  note IH = length (compE2 {V:T=None; e}) = length (compE2 e); Suc n + max_vars e'  length xs;e (Suc n) 
               τred1r P t h (e', xs) (Val v, loc)
  with len ‹ℬ e (Suc n) have "τred1r P t h (e', xs) (Val v, loc)" by(simp)
  hence "τred1r P t h ({V:T=None; e'}, xs) ({V:T=None; Val v}, loc)"
    by(rule Block_None_τred1r_xt)
  thus ?case using V lenxs by(auto elim!: rtranclp.rtrancl_into_rtrancl intro: Red1Block τmove1BlockRed)
next
  case (bisim1TryCatch2 e2 n e' xs loc pc e C V)
  from ‹ℬ (try e catch(C V) e2) n have [simp]: "n = V" and "ℬ e2 (Suc n)" by auto
  note len = n + max_vars {V:Class C=None; e'}  length xs
  hence V: "V < length xs" by simp
  from P,e2,h  (e', xs)  ([v], loc, pc, None)
  have lenxs: "length xs = length loc" by(auto dest: bisim1_length_xs)
  note IH = pc = length (compE2 e2); Suc n + max_vars e'  length xs;e2 (Suc n)
              τred1r P t h (e', xs) (Val v, loc)
  with len ‹Suc (Suc (length (compE2 e) + pc)) = length (compE2 (try e catch(C V) e2)) ‹ℬ e2 (Suc n)
  have "τred1r P t h (e', xs) (Val v, loc)" by(simp)
  hence "τred1r P t h ({V:Class C=None; e'}, xs) ({V:Class C=None; Val v}, loc)"
    by(rule Block_None_τred1r_xt)
  thus ?case using V lenxs by(auto elim!: rtranclp.rtrancl_into_rtrancl intro: Red1Block τmove1BlockRed)
next
  case (bisims1List1 e n e' xs loc es)
  note bisim = P,e,h  (e', xs)  (rev vs, loc, length (compEs2 (e # es)), None)
  then have es: "es = []" and pc: "length (compEs2 (e # es)) = length (compE2 e)"
    by(auto dest: bisim1_pc_length_compE2)
  with bisim obtain val where stk: "rev vs = [val]" and e': "is_val e'  e' = Val val"
    by(auto dest: bisim1_pc_length_compE2D)
  with es pc bisims1List1 have "τred1r P t h (e', xs) (Val val, loc)" by simp
  with stk es show ?case by(auto intro: τred1r_inj_τreds1r)
next
  case (bisims1List2 es n es' xs stk loc pc e v)
  from stk @ [v] = rev vs obtain vs' where vs: "vs = v # vs'" by(cases vs) auto
  with bisims1List2 show ?case by(auto intro: τreds1r_cons_τreds1r)
qed(fastforce dest: bisim1_pc_length_compE2 bisims1_pc_length_compEs2)+

lemma exec_meth_stk_split:
  " P,E,h  (e, xs)  (stk, loc, pc, xcp);
     exec_meth_d (compP2 P) (compE2 E) (stack_xlift (length STK) (compxE2 E 0 0)) t
                h (stk @ STK, loc, pc, xcp) ta h' (stk', loc', pc', xcp') 
   stk''. stk' = stk'' @ STK  exec_meth_d (compP2 P) (compE2 E) (compxE2 E 0 0) t
                                             h (stk, loc, pc, xcp) ta h' (stk'', loc', pc', xcp')"
  (is " _; ?exec E stk STK loc pc xcp stk' loc' pc' xcp'   ?concl E stk STK loc pc xcp stk' loc' pc' xcp'")

  and exec_meth_stk_splits:
  " P,Es,h  (es,xs) [↔] (stk,loc,pc,xcp);
     exec_meth_d (compP2 P) (compEs2 Es) (stack_xlift (length STK) (compxEs2 Es 0 0)) t
                h (stk @ STK, loc, pc, xcp) ta h' (stk', loc', pc', xcp') 
   stk''. stk' = stk'' @ STK  exec_meth_d (compP2 P) (compEs2 Es) (compxEs2 Es 0 0) t
                                             h (stk, loc, pc, xcp) ta h' (stk'', loc', pc', xcp')"
  (is " _; ?execs Es stk STK loc pc xcp stk' loc' pc' xcp'   ?concls Es stk STK loc pc xcp stk' loc' pc' xcp'")
proof(induct E "n :: nat" e xs stk loc pc xcp and Es "n :: nat" es xs stk loc pc xcp
    arbitrary: stk' loc' pc' xcp' STK and stk' loc' pc' xcp' STK rule: bisim1_bisims1_inducts_split)
  case bisim1InSync thus ?case by(auto elim!: exec_meth.cases intro!: exec_meth.intros)
next
  case bisim1Val2 thus ?case by(auto dest: exec_meth_length_compE2_stack_xliftD)
next
  case bisim1New thus ?case
    by (fastforce elim: exec_meth.cases intro: exec_meth.intros split: if_split_asm cong del: image_cong_simp)
next
  case bisim1NewThrow thus ?case by(fastforce elim: exec_meth.cases intro: exec_meth.intros)
next
  case (bisim1NewArray e n e' xs stk loc pc xcp T)
  note bisim = P,e,h  (e', xs)  (stk, loc, pc, xcp)
  note IH = stk' loc' pc' xcp' STK. ?exec e stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl e stk STK loc pc xcp stk' loc' pc' xcp'
  note exec = ?exec (newA Te) stk STK loc pc xcp stk' loc' pc' xcp'
  from bisim have pc: "pc  length (compE2 e)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e)")
    case True
    with exec have "?exec e stk STK loc pc xcp stk' loc' pc' xcp'"
      by(simp add: compxE2_size_convs)(erule exec_meth_take)
    from IH[OF this] show ?thesis by auto
  next
    case False
    with pc have [simp]: "pc = length (compE2 e)" by simp
    with bisim obtain v where [simp]: "stk = [v]" "xcp = None"
      by(auto dest: dest: bisim1_pc_length_compE2D)
    with exec show ?thesis
      apply simp
      apply (erule exec_meth.cases)
       apply (auto 4 4 intro: exec_meth.intros split: if_split_asm cong del: image_cong_simp)
      done
  qed
next
  case (bisim1NewArrayThrow e n a xs stk loc pc T)
  note bisim = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  note IH = stk' loc' pc' xcp' STK. ?exec e stk STK loc pc a stk' loc' pc' xcp'
              ?concl e stk STK loc pc a stk' loc' pc' xcp'
  note exec = ?exec (newA Te) stk STK loc pc a stk' loc' pc' xcp'
  from bisim have pc: "pc < length (compE2 e)" and [simp]: "xs = loc"
    by(auto dest: bisim1_ThrowD)
  from exec have "?exec e stk STK loc pc a stk' loc' pc' xcp'"
    by(simp)(erule exec_meth_take[OF _ pc])
  from IH[OF this] show ?case by(auto)
next
  case bisim1NewArrayFail thus ?case
    by(auto elim!: exec_meth.cases dest: match_ex_table_pcsD simp add: stack_xlift_compxEs2 stack_xlift_compxE2)
next
  case (bisim1Cast e n e' xs stk loc pc xcp T)
  note bisim = P,e,h  (e', xs)  (stk, loc, pc, xcp)
  note IH = stk' loc' pc' xcp' STK. ?exec e stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl e stk STK loc pc xcp stk' loc' pc' xcp'
  note exec = ?exec (Cast T e) stk STK loc pc xcp stk' loc' pc' xcp'
  from bisim have pc: "pc  length (compE2 e)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e)")
    case True
    with exec have "?exec e stk STK loc pc xcp stk' loc' pc' xcp'"
      by(simp add: compxE2_size_convs)(erule exec_meth_take)
    from IH[OF this] show ?thesis by auto
  next
    case False
    with pc have [simp]: "pc = length (compE2 e)" by simp
    with bisim obtain v where [simp]: "stk = [v]" "xcp = None"
      by(auto dest: dest: bisim1_pc_length_compE2D)
    with exec show ?thesis apply(simp)
      by(erule exec_meth.cases)(auto intro!: exec_meth.intros split: if_split_asm)
  qed
next
  case (bisim1CastThrow e n a xs stk loc pc T)
  note bisim = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  note IH = stk' loc' pc' xcp' STK. ?exec e stk STK loc pc a stk' loc' pc' xcp'
              ?concl e stk STK loc pc a stk' loc' pc' xcp'
  note exec = ?exec (Cast T e) stk STK loc pc a stk' loc' pc' xcp'
  from bisim have pc: "pc < length (compE2 e)" and [simp]: "xs = loc"
    by(auto dest: bisim1_ThrowD)
  from exec have "?exec e stk STK loc pc a stk' loc' pc' xcp'"
    by(simp)(erule exec_meth_take[OF _ pc])
  from IH[OF this] show ?case by(auto)
next
  case bisim1CastFail thus ?case
    by(auto elim!: exec_meth.cases dest: match_ex_table_pcsD simp add: stack_xlift_compxEs2 stack_xlift_compxE2)
next
  case (bisim1InstanceOf e n e' xs stk loc pc xcp T)
  note bisim = P,e,h  (e', xs)  (stk, loc, pc, xcp)
  note IH = stk' loc' pc' xcp' STK. ?exec e stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl e stk STK loc pc xcp stk' loc' pc' xcp'
  note exec = ?exec (e instanceof T) stk STK loc pc xcp stk' loc' pc' xcp'
  from bisim have pc: "pc  length (compE2 e)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e)")
    case True
    with exec have "?exec e stk STK loc pc xcp stk' loc' pc' xcp'"
      by(simp add: compxE2_size_convs)(erule exec_meth_take)
    from IH[OF this] show ?thesis by auto
  next
    case False
    with pc have [simp]: "pc = length (compE2 e)" by simp
    with bisim obtain v where [simp]: "stk = [v]" "xcp = None"
      by(auto dest: dest: bisim1_pc_length_compE2D)
    with exec show ?thesis apply(simp)
      by(erule exec_meth.cases)(auto intro!: exec_meth.intros split: if_split_asm)
  qed
next
  case (bisim1InstanceOfThrow e n a xs stk loc pc T)
  note bisim = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  note IH = stk' loc' pc' xcp' STK. ?exec e stk STK loc pc a stk' loc' pc' xcp'
              ?concl e stk STK loc pc a stk' loc' pc' xcp'
  note exec = ?exec (e instanceof T) stk STK loc pc a stk' loc' pc' xcp'
  from bisim have pc: "pc < length (compE2 e)" and [simp]: "xs = loc"
    by(auto dest: bisim1_ThrowD)
  from exec have "?exec e stk STK loc pc a stk' loc' pc' xcp'"
    by(simp)(erule exec_meth_take[OF _ pc])
  from IH[OF this] show ?case by(auto)
next
  case bisim1Val thus ?case by(fastforce elim: exec_meth.cases intro: exec_meth.intros)
next
  case bisim1Var thus ?case by(fastforce elim: exec_meth.cases intro: exec_meth.intros)
next
  case (bisim1BinOp1 e1 n e1' xs stk loc pc xcp e2 bop)
  note IH1 = stk' loc' pc' xcp' STK. ?exec e1 stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl e1 stk STK loc pc xcp stk' loc' pc' xcp'
  note IH2 = xs stk' loc' pc' xcp' STK. ?exec e2 [] STK xs 0 None stk' loc' pc' xcp'
              ?concl e2 [] STK xs 0 None stk' loc' pc' xcp'
  note bisim1 = P,e1,h  (e1', xs)  (stk, loc, pc, xcp)
  note bisim2 = P,e2,h  (e2, loc)  ([], loc, 0, None)
  note exec = ?exec (e1 «bop» e2) stk STK loc pc xcp stk' loc' pc' xcp'
  from bisim1 have pc: "pc  length (compE2 e1)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e1)")
    case True
    with exec have "?exec e1 stk STK loc pc xcp stk' loc' pc' xcp'"
      by(simp add: compxE2_size_convs)(erule exec_meth_take_xt)
    from IH1[OF this] show ?thesis by auto
  next
    case False
    with pc have pc: "pc = length (compE2 e1)" by simp
    with exec have "pc'  length (compE2 e1)"
      by(simp add: compxE2_size_convs stack_xlift_compxE2)(auto split: bop.splits elim!: exec_meth_drop_xt_pc)
    then obtain PC where PC: "pc' = PC + length (compE2 e1)"
      by -(rule_tac PC34="pc' - length (compE2 e1)" in that, simp)
    from pc bisim1 obtain v where "stk = [v]" "xcp = None" by(auto dest: bisim1_pc_length_compE2D)
    with exec pc have "exec_meth_d (compP2 P) (compE2 e1 @ compE2 e2)
   (stack_xlift (length STK) (compxE2 e1 0 0 @ compxE2 e2 (length (compE2 e1)) (Suc 0))) t h (stk @ STK, loc, length (compE2 e1) + 0, xcp) ta h' (stk', loc', pc', xcp')"
      by-(rule exec_meth_take, auto)
    hence "?exec e2 [] (v # STK) loc 0 None stk' loc' (pc' - length (compE2 e1)) xcp'"
      using stk = [v] xcp = None›
      by -(rule exec_meth_drop_xt, auto simp add: stack_xlift_compxE2 shift_compxE2)
    from IH2[OF this] PC obtain stk'' where stk': "stk' = stk'' @ v # STK"
      and "exec_meth_d (compP2 P) (compE2 e2) (compxE2 e2 0 0) t h ([], loc, 0, None) ta h' (stk'', loc', PC, xcp')" by auto
    hence "exec_meth_d (compP2 P) ((compE2 e1 @ compE2 e2) @ [BinOpInstr bop])
        (compxE2 e1 0 0 @ shift (length (compE2 e1)) (stack_xlift (length [v]) (compxE2 e2 0 0))) t h
        ([] @ [v], loc, length (compE2 e1) + 0, None) ta h' (stk'' @ [v], loc', length (compE2 e1) + PC, xcp')"
      apply -
      apply(rule exec_meth_append)
      apply(rule append_exec_meth_xt)
      apply(erule exec_meth_stk_offer)
      by(auto)
    thus ?thesis using stk = [v] xcp = None› stk' pc PC
      by(clarsimp simp add: shift_compxE2 stack_xlift_compxE2 ac_simps)
  qed
next
  case (bisim1BinOp2 e2 n e2' xs stk loc pc xcp e1 bop v1)
  note IH2 = stk' loc' pc' xcp' STK. ?exec e2 stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl e2 stk STK loc pc xcp stk' loc' pc' xcp'
  note bisim1 = P,e1,h  (e1, xs)  ([], xs, 0, None)
  note bisim2 = P,e2,h  (e2', xs)  (stk, loc, pc, xcp)
  note exec = ?exec (e1 «bop» e2) (stk @ [v1]) STK loc (length (compE2 e1) + pc) xcp stk' loc' pc' xcp'
  from bisim2 have pc: "pc  length (compE2 e2)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e2)")
    case True
    from exec have "exec_meth_d (compP2 P) ((compE2 e1 @ compE2 e2) @ [BinOpInstr bop])
      (stack_xlift (length STK) (compxE2 e1 0 0) @ shift (length (compE2 e1)) (stack_xlift (length STK) (compxE2 e2 0 (Suc 0)))) t
      h (stk @ v1 # STK, loc, length (compE2 e1) + pc, xcp) ta h' (stk', loc', pc', xcp')" by(simp add: compxE2_size_convs)
    hence exec': "exec_meth_d (compP2 P) (compE2 e1 @ compE2 e2) (stack_xlift (length STK) (compxE2 e1 0 0) @
      shift (length (compE2 e1)) (stack_xlift (length STK) (compxE2 e2 0 (Suc 0)))) t
      h (stk @ v1 # STK, loc, length (compE2 e1) + pc, xcp) ta h' (stk', loc', pc', xcp')"
      by(rule exec_meth_take)(simp add: True)
    hence "exec_meth_d (compP2 P) (compE2 e2) (stack_xlift (length STK) (compxE2 e2 0 (Suc 0))) t
      h (stk @ v1 # STK, loc, pc, xcp) ta h' (stk', loc', pc' - length (compE2 e1), xcp')"
      by(rule exec_meth_drop_xt)(auto simp add: stack_xlift_compxE2)
    hence "?exec e2 stk (v1 # STK) loc pc xcp stk' loc' (pc' - length (compE2 e1)) xcp'"
      by(simp add: compxE2_stack_xlift_convs)
    from IH2[OF this] obtain stk'' where stk': "stk' = stk'' @ v1 # STK"
      and exec'': "exec_meth_d (compP2 P) (compE2 e2) (compxE2 e2 0 0) t h (stk, loc, pc, xcp) ta h' (stk'', loc', pc' - length (compE2 e1), xcp')" by blast
    from exec'' have "exec_meth_d (compP2 P) (compE2 e2) (stack_xlift (length [v1]) (compxE2 e2 0 0)) t h (stk @ [v1], loc, pc, xcp)
      ta h' (stk'' @ [v1], loc', pc' - length (compE2 e1), xcp')"
      by(rule exec_meth_stk_offer)
    hence "exec_meth_d (compP2 P) (compE2 e1 @ compE2 e2) (compxE2 e1 0 0 @ shift (length (compE2 e1)) (stack_xlift (length [v1]) (compxE2 e2 0 0))) t h (stk @ [v1], loc, length (compE2 e1) + pc, xcp)
      ta h' (stk'' @ [v1], loc', length (compE2 e1) + (pc' - length (compE2 e1)), xcp')"
      by(rule append_exec_meth_xt) auto
    hence "exec_meth_d (compP2 P) ((compE2 e1 @ compE2 e2) @ [BinOpInstr bop]) (compxE2 e1 0 0 @ shift (length (compE2 e1)) (stack_xlift (length [v1]) (compxE2 e2 0 0))) t h (stk @ [v1], loc, length (compE2 e1) + pc, xcp)
      ta h' (stk'' @ [v1], loc', length (compE2 e1) + (pc' - length (compE2 e1)), xcp')"
      by(rule exec_meth_append)
    moreover from exec' have "pc'  length (compE2 e1)"
      by(rule exec_meth_drop_xt_pc)(auto simp add: stack_xlift_compxE2)
    ultimately show ?thesis using stk' by(simp add: stack_xlift_compxE2 shift_compxE2)
  next
    case False
    with pc have pc: "pc = length (compE2 e2)" by simp
    with bisim2 obtain v2 where [simp]: "stk = [v2]" "xcp = None"
      by(auto dest: dest: bisim1_pc_length_compE2D)
    with exec pc show ?thesis 
      by(fastforce elim: exec_meth.cases split: sum.split_asm intro!: exec_meth.intros)
  qed
next
  case (bisim1BinOpThrow1 e1 n a xs stk loc pc e2 bop)
  note bisim1 = P,e1,h  (Throw a, xs)  (stk, loc, pc, a)
  note IH1 = stk' loc' pc' xcp' STK. ?exec e1 stk STK loc pc a stk' loc' pc' xcp'
              ?concl e1 stk STK loc pc a stk' loc' pc' xcp'
  note exec = ?exec (e1 «bop» e2) stk STK loc pc a stk' loc' pc' xcp'
  from bisim1 have pc: "pc < length (compE2 e1)" and [simp]: "xs = loc"
    by(auto dest: bisim1_ThrowD)
  from exec have "exec_meth_d (compP2 P) (compE2 e1 @ (compE2 e2 @ [BinOpInstr bop]))
     (stack_xlift (length STK) (compxE2 e1 0 0) @ shift (length (compE2 e1)) (stack_xlift (length STK) (compxE2 e2 0 (Suc 0)))) t
     h (stk @ STK, loc, pc, a) ta h' (stk', loc', pc', xcp')" by(simp add: compxE2_size_convs)
  hence "?exec e1 stk STK loc pc a stk' loc' pc' xcp'"
    by(rule exec_meth_take_xt)(rule pc)
  from IH1[OF this] show ?case by(auto)
next
  case (bisim1BinOpThrow2 e2 n a xs stk loc pc e1 bop v1)
  note bisim2 = P,e2,h  (Throw a, xs)  (stk, loc, pc, a)
  note IH2 = stk' loc' pc' xcp' STK. ?exec e2 stk STK loc pc a stk' loc' pc' xcp'
              ?concl e2 stk STK loc pc a stk' loc' pc' xcp'
  note exec = ?exec (e1 «bop» e2) (stk @ [v1]) STK loc (length (compE2 e1) + pc) a stk' loc' pc' xcp'
  from bisim2 have pc: "pc < length (compE2 e2)" and [simp]: "xs = loc"
    by(auto dest: bisim1_ThrowD)
  from exec have "exec_meth_d (compP2 P) ((compE2 e1 @ compE2 e2) @ [BinOpInstr bop])
     (stack_xlift (length STK) (compxE2 e1 0 0) @ shift (length (compE2 e1)) (stack_xlift (length STK) (compxE2 e2 0 (Suc 0))))
     t h (stk @ v1 # STK, loc, length (compE2 e1) + pc, a) ta h' (stk', loc', pc', xcp')"
    by(simp add: compxE2_size_convs)
  hence exec': "exec_meth_d (compP2 P) (compE2 e1 @ compE2 e2)
     (stack_xlift (length STK) (compxE2 e1 0 0) @ shift (length (compE2 e1)) (stack_xlift (length STK) (compxE2 e2 0 (Suc 0)))) t
     h (stk @ v1 # STK, loc, length (compE2 e1) + pc, a) ta h' (stk', loc', pc', xcp')"
    by(rule exec_meth_take)(simp add: pc)
  hence "exec_meth_d (compP2 P) (compE2 e2) (stack_xlift (length STK) (compxE2 e2 0 (Suc 0))) t
     h (stk @ v1 # STK, loc, pc, a) ta h' (stk', loc', pc' - length (compE2 e1), xcp')"
    by(rule exec_meth_drop_xt)(auto simp add: stack_xlift_compxE2)
  hence "?exec e2 stk (v1 # STK) loc pc a stk' loc' (pc' - length (compE2 e1)) xcp'"
    by(simp add: compxE2_stack_xlift_convs)
  from IH2[OF this] obtain stk'' where stk': "stk' = stk'' @ v1 # STK" and
    exec'': "exec_meth_d (compP2 P) (compE2 e2) (compxE2 e2 0 0) t h (stk, loc, pc, a) ta h' (stk'', loc', pc' - length (compE2 e1), xcp')" by blast
  from exec'' have "exec_meth_d (compP2 P) (compE2 e2) (stack_xlift (length [v1]) (compxE2 e2 0 0)) t h (stk @ [v1], loc, pc, a)
      ta h' (stk'' @ [v1], loc', pc' - length (compE2 e1), xcp')"
    by(rule exec_meth_stk_offer)
  hence "exec_meth_d (compP2 P) (compE2 e1 @ compE2 e2) (compxE2 e1 0 0 @ shift (length (compE2 e1)) (stack_xlift (length [v1]) (compxE2 e2 0 0))) t h (stk @ [v1], loc, length (compE2 e1) + pc, a)
      ta h' (stk'' @ [v1], loc', length (compE2 e1) + (pc' - length (compE2 e1)), xcp')"
    by(rule append_exec_meth_xt)(auto)
  hence "exec_meth_d (compP2 P) ((compE2 e1 @ compE2 e2) @ [BinOpInstr bop]) (compxE2 e1 0 0 @ shift (length (compE2 e1)) (stack_xlift (length [v1]) (compxE2 e2 0 0))) t h (stk @ [v1], loc, length (compE2 e1) + pc, a)
      ta h' (stk'' @ [v1], loc', length (compE2 e1) + (pc' - length (compE2 e1)), xcp')"
    by(rule exec_meth_append)
  moreover from exec' have pc': "pc'  length (compE2 e1)"
    by(rule exec_meth_drop_xt_pc)(auto simp add: stack_xlift_compxE2)
  ultimately show ?case using stk' by(auto simp add: stack_xlift_compxE2 shift_compxE2)
next
  case bisim1BinOpThrow thus ?case
    by(auto elim!: exec_meth.cases dest: match_ex_table_pcsD simp add: stack_xlift_compxEs2 stack_xlift_compxE2)
next
  case (bisim1LAss1 e n e' xs stk loc pc xcp V)
  note bisim = P,e,h  (e', xs)  (stk, loc, pc, xcp)
  note IH = stk' loc' pc' xcp' STK. ?exec e stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl e stk STK loc pc xcp stk' loc' pc' xcp'
  note exec = ?exec (V := e) stk STK loc pc xcp stk' loc' pc' xcp'
  from bisim have pc: "pc  length (compE2 e)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e)")
    case True
    with exec have "?exec e stk STK loc pc xcp stk' loc' pc' xcp'"
      by(simp add: compxE2_size_convs)(erule exec_meth_take)
    from IH[OF this] show ?thesis by auto
  next
    case False
    with pc have [simp]: "pc = length (compE2 e)" by simp
    with bisim obtain v where [simp]: "stk = [v]" "xcp = None"
      by(auto dest: dest: bisim1_pc_length_compE2D)
    with exec show ?thesis apply(simp)
      by(erule exec_meth.cases)(auto intro!: exec_meth.intros)
  qed
next
  case (bisim1LAss2 e n xs V)
  thus ?case by(fastforce elim: exec_meth.cases intro: exec_meth.intros)
next
  case (bisim1LAssThrow e n a xs stk loc pc V)
  note bisim = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  note IH = stk' loc' pc' xcp' STK. ?exec e stk STK loc pc a stk' loc' pc' xcp'
              ?concl e stk STK loc pc a stk' loc' pc' xcp'
  note exec = ?exec (V := e) stk STK loc pc a stk' loc' pc' xcp'
  from bisim have pc: "pc < length (compE2 e)" and [simp]: "xs = loc"
    by(auto dest: bisim1_ThrowD)
  from exec have "?exec e stk STK loc pc a stk' loc' pc' xcp'"
    by(simp)(erule exec_meth_take[OF _ pc])
  from IH[OF this] show ?case by(auto)
next
  case (bisim1AAcc1 a n a' xs stk loc pc xcp i)
  note IH1 = stk' loc' pc' xcp' STK. ?exec a stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl a stk STK loc pc xcp stk' loc' pc' xcp'
  note IH2 = xs stk' loc' pc' xcp' STK. ?exec i [] STK xs 0 None stk' loc' pc' xcp'
              ?concl i [] STK xs 0 None stk' loc' pc' xcp'
  note bisim1 = P,a,h  (a', xs)  (stk, loc, pc, xcp)
  note bisim2 = P,i,h  (i, loc)  ([], loc, 0, None)
  note exec = ?exec (ai) stk STK loc pc xcp stk' loc' pc' xcp'
  from bisim1 have pc: "pc  length (compE2 a)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 a)")
    case True
    with exec have "?exec a stk STK loc pc xcp stk' loc' pc' xcp'"
      by(simp add: compxE2_size_convs)(erule exec_meth_take_xt)
    from IH1[OF this] show ?thesis by auto
  next
    case False
    with pc have pc: "pc = length (compE2 a)" by simp
    with exec have "pc'  length (compE2 a)"
      by(simp add: compxE2_size_convs stack_xlift_compxE2)(auto elim!: exec_meth_drop_xt_pc)
    then obtain PC where PC: "pc' = PC + length (compE2 a)"
      by -(rule_tac PC34="pc' - length (compE2 a)" in that, simp)
    from pc bisim1 obtain v where "stk = [v]" "xcp = None" by(auto dest: bisim1_pc_length_compE2D)
    with exec pc have "exec_meth_d (compP2 P) (compE2 a @ compE2 i)
   (stack_xlift (length STK) (compxE2 a 0 0 @ compxE2 i (length (compE2 a)) (Suc 0))) t h (stk @ STK, loc, length (compE2 a) + 0, xcp) ta h' (stk', loc', pc', xcp')"
      by-(rule exec_meth_take, auto)
    hence "?exec i [] (v # STK) loc 0 None stk' loc' (pc' - length (compE2 a)) xcp'"
      using stk = [v] xcp = None›
      by -(rule exec_meth_drop_xt, auto simp add: stack_xlift_compxE2 shift_compxE2)
    from IH2[OF this] PC obtain stk'' where stk': "stk' = stk'' @ v # STK"
      and "exec_meth_d (compP2 P) (compE2 i) (compxE2 i 0 0) t h ([], loc, 0, None) ta h' (stk'', loc', PC, xcp')" by auto
    hence "exec_meth_d (compP2 P) ((compE2 a @ compE2 i) @ [ALoad])
        (compxE2 a 0 0 @ shift (length (compE2 a)) (stack_xlift (length [v]) (compxE2 i 0 0))) t h
        ([] @ [v], loc, length (compE2 a) + 0, None) ta h' (stk'' @ [v], loc', length (compE2 a) + PC, xcp')"
      apply -
      apply(rule exec_meth_append)
      apply(rule append_exec_meth_xt)
      apply(erule exec_meth_stk_offer)
      by(auto)
    thus ?thesis using stk = [v] xcp = None› stk' pc PC
      by(clarsimp simp add: shift_compxE2 stack_xlift_compxE2 ac_simps)
  qed
next
  case (bisim1AAcc2 i n i' xs stk loc pc xcp a v1)
  note IH2 = stk' loc' pc' xcp' STK. ?exec i stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl i stk STK loc pc xcp stk' loc' pc' xcp'
  note bisim2 = P,i,h  (i', xs)  (stk, loc, pc, xcp)
  note exec = ?exec (ai) (stk @ [v1]) STK loc (length (compE2 a) + pc) xcp stk' loc' pc' xcp'
  from bisim2 have pc: "pc  length (compE2 i)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 i)")
    case True
    from exec have "exec_meth_d (compP2 P) ((compE2 a @ compE2 i) @ [ALoad])
      (stack_xlift (length STK) (compxE2 a 0 0) @ shift (length (compE2 a)) (stack_xlift (length STK) (compxE2 i 0 (Suc 0)))) t
      h (stk @ v1 # STK, loc, length (compE2 a) + pc, xcp) ta h' (stk', loc', pc', xcp')" by(simp add: compxE2_size_convs)
    hence exec': "exec_meth_d (compP2 P) (compE2 a @ compE2 i) (stack_xlift (length STK) (compxE2 a 0 0) @
      shift (length (compE2 a)) (stack_xlift (length STK) (compxE2 i 0 (Suc 0)))) t
      h (stk @ v1 # STK, loc, length (compE2 a) + pc, xcp) ta h' (stk', loc', pc', xcp')"
      by(rule exec_meth_take)(simp add: True)
    hence "exec_meth_d (compP2 P) (compE2 i) (stack_xlift (length STK) (compxE2 i 0 (Suc 0))) t
      h (stk @ v1 # STK, loc, pc, xcp) ta h' (stk', loc', pc' - length (compE2 a), xcp')"
      by(rule exec_meth_drop_xt)(auto simp add: stack_xlift_compxE2)
    hence "?exec i stk (v1 # STK) loc pc xcp stk' loc' (pc' - length (compE2 a)) xcp'"
      by(simp add: compxE2_stack_xlift_convs)
    from IH2[OF this] obtain stk'' where stk': "stk' = stk'' @ v1 # STK"
      and exec'': "exec_meth_d (compP2 P) (compE2 i) (compxE2 i 0 0) t h (stk, loc, pc, xcp) ta h' (stk'', loc', pc' - length (compE2 a), xcp')" by blast
    from exec'' have "exec_meth_d (compP2 P) (compE2 i) (stack_xlift (length [v1]) (compxE2 i 0 0)) t h (stk @ [v1], loc, pc, xcp)
      ta h' (stk'' @ [v1], loc', pc' - length (compE2 a), xcp')"
      by(rule exec_meth_stk_offer)
    hence "exec_meth_d (compP2 P) (compE2 a @ compE2 i) (compxE2 a 0 0 @ shift (length (compE2 a)) (stack_xlift (length [v1]) (compxE2 i 0 0))) t h (stk @ [v1], loc, length (compE2 a) + pc, xcp)
      ta h' (stk'' @ [v1], loc', length (compE2 a) + (pc' - length (compE2 a)), xcp')"
      by(rule append_exec_meth_xt) auto
    hence "exec_meth_d (compP2 P) ((compE2 a @ compE2 i) @ [ALoad]) (compxE2 a 0 0 @ shift (length (compE2 a)) (stack_xlift (length [v1]) (compxE2 i 0 0))) t h (stk @ [v1], loc, length (compE2 a) + pc, xcp)
      ta h' (stk'' @ [v1], loc', length (compE2 a) + (pc' - length (compE2 a)), xcp')"
      by(rule exec_meth_append)
    moreover from exec' have "pc'  length (compE2 a)"
      by(rule exec_meth_drop_xt_pc)(auto simp add: stack_xlift_compxE2)
    ultimately show ?thesis using stk' by(simp add: stack_xlift_compxE2 shift_compxE2)
  next
    case False
    with pc have pc: "pc = length (compE2 i)" by simp
    with bisim2 obtain v2 where [simp]: "stk = [v2]" "xcp = None"
      by(auto dest: dest: bisim1_pc_length_compE2D)
    with exec pc show ?thesis
      by(clarsimp)(erule exec_meth.cases, auto intro!: exec_meth.intros split: if_split_asm)
  qed
next
  case (bisim1AAccThrow1 A n a xs stk loc pc i)
  note bisim1 = P,A,h  (Throw a, xs)  (stk, loc, pc, a)
  note IH1 = stk' loc' pc' xcp' STK. ?exec A stk STK loc pc a stk' loc' pc' xcp'
              ?concl A stk STK loc pc a stk' loc' pc' xcp'
  note exec = ?exec (Ai) stk STK loc pc a stk' loc' pc' xcp'
  from bisim1 have pc: "pc < length (compE2 A)" and [simp]: "xs = loc"
    by(auto dest: bisim1_ThrowD)
  from exec have "exec_meth_d (compP2 P) (compE2 A @ (compE2 i @ [ALoad]))
     (stack_xlift (length STK) (compxE2 A 0 0) @ shift (length (compE2 A)) (stack_xlift (length STK) (compxE2 i 0 (Suc 0)))) t
     h (stk @ STK, loc, pc, a) ta h' (stk', loc', pc', xcp')" by(simp add: compxE2_size_convs)
  hence "?exec A stk STK loc pc a stk' loc' pc' xcp'" by(rule exec_meth_take_xt)(rule pc)
  from IH1[OF this] show ?case by(auto)
next
  case (bisim1AAccThrow2 i n a xs stk loc pc A v1)
  note bisim2 = P,i,h  (Throw a, xs)  (stk, loc, pc, a)
  note IH2 = stk' loc' pc' xcp' STK. ?exec i stk STK loc pc a stk' loc' pc' xcp'
              ?concl i stk STK loc pc a stk' loc' pc' xcp'
  note exec = ?exec (Ai) (stk @ [v1]) STK loc (length (compE2 A) + pc) a stk' loc' pc' xcp'
  from bisim2 have pc: "pc < length (compE2 i)" and [simp]: "xs = loc"
    by(auto dest: bisim1_ThrowD)
  from exec have "exec_meth_d (compP2 P) ((compE2 A @ compE2 i) @ [ALoad])
     (stack_xlift (length STK) (compxE2 A 0 0) @ shift (length (compE2 A)) (stack_xlift (length STK) (compxE2 i 0 (Suc 0)))) t
     h (stk @ v1 # STK, loc, length (compE2 A) + pc, a) ta h' (stk', loc', pc', xcp')"
    by(simp add: compxE2_size_convs)
  hence exec': "exec_meth_d (compP2 P) (compE2 A @ compE2 i)
     (stack_xlift (length STK) (compxE2 A 0 0) @ shift (length (compE2 A)) (stack_xlift (length STK) (compxE2 i 0 (Suc 0)))) t
     h (stk @ v1 # STK, loc, length (compE2 A) + pc, a) ta h' (stk', loc', pc', xcp')"
    by(rule exec_meth_take)(simp add: pc)
  hence "exec_meth_d (compP2 P) (compE2 i) (stack_xlift (length STK) (compxE2 i 0 (Suc 0))) t
     h (stk @ v1 # STK, loc, pc, a) ta h' (stk', loc', pc' - length (compE2 A), xcp')"
    by(rule exec_meth_drop_xt)(auto simp add: stack_xlift_compxE2)
  hence "?exec i stk (v1 # STK) loc pc a stk' loc' (pc' - length (compE2 A)) xcp'"
    by(simp add: compxE2_stack_xlift_convs)
  from IH2[OF this] obtain stk'' where stk': "stk' = stk'' @ v1 # STK" and
    exec'': "exec_meth_d (compP2 P) (compE2 i) (compxE2 i 0 0) t h (stk, loc, pc, a) ta h' (stk'', loc', pc' - length (compE2 A), xcp')" by blast
  from exec'' have "exec_meth_d (compP2 P) (compE2 i) (stack_xlift (length [v1]) (compxE2 i 0 0)) t h (stk @ [v1], loc, pc, a)
      ta h' (stk'' @ [v1], loc', pc' - length (compE2 A), xcp')"
    by(rule exec_meth_stk_offer)
  hence "exec_meth_d (compP2 P) (compE2 A @ compE2 i) (compxE2 A 0 0 @ shift (length (compE2 A)) (stack_xlift (length [v1]) (compxE2 i 0 0))) t h (stk @ [v1], loc, length (compE2 A) + pc, a)
      ta h' (stk'' @ [v1], loc', length (compE2 A) + (pc' - length (compE2 A)), xcp')"
    by(rule append_exec_meth_xt)(auto)
  hence "exec_meth_d (compP2 P) ((compE2 A @ compE2 i) @ [ALoad]) (compxE2 A 0 0 @ shift (length (compE2 A)) (stack_xlift (length [v1]) (compxE2 i 0 0))) t h (stk @ [v1], loc, length (compE2 A) + pc, a)
      ta h' (stk'' @ [v1], loc', length (compE2 A) + (pc' - length (compE2 A)), xcp')"
    by(rule exec_meth_append)
  moreover from exec' have pc': "pc'  length (compE2 A)"
    by(rule exec_meth_drop_xt_pc)(auto simp add: stack_xlift_compxE2)
  ultimately show ?case using stk' by(auto simp add: stack_xlift_compxE2 shift_compxE2)
next
  case bisim1AAccFail thus ?case
    by(auto elim!: exec_meth.cases dest: match_ex_table_pcsD simp add: stack_xlift_compxEs2 stack_xlift_compxE2)
next
  case (bisim1AAss1 a n a' xs stk loc pc xcp i e)
  note IH1 = stk' loc' pc' xcp' STK. ?exec a stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl a stk STK loc pc xcp stk' loc' pc' xcp'
  note IH2 = xs stk' loc' pc' xcp' STK. ?exec i [] STK xs 0 None stk' loc' pc' xcp'
              ?concl i [] STK xs 0 None stk' loc' pc' xcp'
  note bisim1 = P,a,h  (a', xs)  (stk, loc, pc, xcp)
  note bisim2 = P,i,h  (i, loc)  ([], loc, 0, None)
  note exec = ?exec (ai := e) stk STK loc pc xcp stk' loc' pc' xcp'
  from bisim1 have pc: "pc  length (compE2 a)" by(rule bisim1_pc_length_compE2)
  from exec have exec': "exec_meth_d (compP2 P) (compE2 a @ compE2 i @ compE2 e @ [AStore, Push Unit]) (stack_xlift (length STK) (compxE2 a 0 0) @ shift (length (compE2 a)) (stack_xlift (length STK) (compxE2 i 0 (Suc 0) @ compxE2 e (length (compE2 i)) (Suc (Suc 0))))) t
    h (stk @ STK, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
    by(simp add: compxE2_size_convs)
  show ?case
  proof(cases "pc < length (compE2 a)")
    case True
    with exec' have "?exec a stk STK loc pc xcp stk' loc' pc' xcp'" by(rule exec_meth_take_xt)
    from IH1[OF this] show ?thesis by auto
  next
    case False
    with pc have pc: "pc = length (compE2 a)" by simp
    with exec' have "pc'  length (compE2 a)" by -(erule exec_meth_drop_xt_pc, auto)
    then obtain PC where PC: "pc' = PC + length (compE2 a)"
      by -(rule_tac PC34="pc' - length (compE2 a)" in that, simp)
    from pc bisim1 obtain v where "stk = [v]" "xcp = None" by(auto dest: bisim1_pc_length_compE2D)
    with exec PC pc
    have "exec_meth_d (compP2 P) ((compE2 a @ compE2 i) @ compE2 e @ [AStore, Push Unit]) (stack_xlift (length STK) (compxE2 a 0 0 @ shift (length (compE2 a)) (compxE2 i 0 (Suc 0))) @ shift (length (compE2 a @ compE2 i)) (compxE2 e 0 (length STK + Suc (Suc 0)))) t
    h (v # STK, loc, length (compE2 a) + 0, None) ta h' (stk', loc', length (compE2 a) + PC, xcp')" 
      by(simp add: shift_compxE2 stack_xlift_compxE2 ac_simps)
    hence "exec_meth_d (compP2 P) (compE2 a @ compE2 i)
   (stack_xlift (length STK) (compxE2 a 0 0 @ shift (length (compE2 a)) (compxE2 i 0 (Suc 0)))) t h (v # STK, loc, length (compE2 a) + 0, None) ta h' (stk', loc', length (compE2 a) + PC, xcp')"
      by(rule exec_meth_take_xt) simp
    hence "?exec i [] (v # STK) loc 0 None stk' loc' ((length (compE2 a) + PC) - length (compE2 a)) xcp'"
      by -(rule exec_meth_drop_xt, auto simp add: stack_xlift_compxE2 shift_compxE2)
    from IH2[OF this] PC obtain stk'' where stk': "stk' = stk'' @ v # STK"
      and "exec_meth_d (compP2 P) (compE2 i) (compxE2 i 0 0) t h ([], loc, 0, None) ta h' (stk'', loc', PC, xcp')" by auto
    hence "exec_meth_d (compP2 P) ((compE2 a @ compE2 i) @ (compE2 e @ [AStore, Push Unit]))
        ((compxE2 a 0 0 @ shift (length (compE2 a)) (stack_xlift (length [v]) (compxE2 i 0 0))) @
         shift (length (compE2 a @ compE2 i)) (compxE2 e 0 (Suc (Suc 0)))) t h
        ([] @ [v], loc, length (compE2 a) + 0, None) ta h' (stk'' @ [v], loc', length (compE2 a) + PC, xcp')"
      apply -
      apply(rule exec_meth_append_xt)
      apply(rule append_exec_meth_xt)
      apply(erule exec_meth_stk_offer)
      by(auto)
    thus ?thesis using stk = [v] xcp = None› stk' pc PC
      by(clarsimp simp add: shift_compxE2 stack_xlift_compxE2 ac_simps)
  qed
next
  case (bisim1AAss2 i n i' xs stk loc pc xcp a e v)
  note IH2 = stk' loc' pc' xcp' STK. ?exec i stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl i stk STK loc pc xcp stk' loc' pc' xcp'
  note IH3 = xs stk' loc' pc' xcp' STK. ?exec e [] STK xs 0 None stk' loc' pc' xcp'
              ?concl e [] STK xs 0 None stk' loc' pc' xcp'
  note bisim2 = P,i,h  (i', xs)  (stk, loc, pc, xcp)
  note bisim3 = P,e,h  (e, loc)  ([], loc, 0, None)
  note exec = ?exec (ai := e) (stk @ [v]) STK loc (length (compE2 a) + pc) xcp stk' loc' pc' xcp'
  from bisim2 have pc: "pc  length (compE2 i)" by(rule bisim1_pc_length_compE2)
  from exec have exec': "v'. exec_meth_d (compP2 P) ((compE2 a @ compE2 i) @ compE2 e @ [AStore, Push Unit]) ((compxE2 a 0 (length STK) @ shift (length (compE2 a)) (stack_xlift (length (v # STK)) (compxE2 i 0 0))) @ shift (length (compE2 a @ compE2 i)) (stack_xlift (length (v' # v # STK)) (compxE2 e 0 0))) t
    h (stk @ v # STK, loc, length (compE2 a) + pc, xcp) ta h' (stk', loc', pc', xcp')"
    by(simp add: shift_compxE2 stack_xlift_compxE2)
  show ?case
  proof(cases "pc < length (compE2 i)")
    case True with exec'[of arbitrary]
    have exec'': "exec_meth_d (compP2 P) (compE2 a @ compE2 i) (compxE2 a 0 (length STK) @ shift (length (compE2 a)) (stack_xlift (length (v # STK)) (compxE2 i 0 0))) t h (stk @ v # STK, loc, length (compE2 a) + pc, xcp) ta h' (stk', loc', pc', xcp')"
      by-(erule exec_meth_take_xt, simp)
    hence "?exec i stk (v # STK) loc pc xcp stk' loc' (pc' - length (compE2 a)) xcp'"
      by(rule exec_meth_drop_xt) auto
    from IH2[OF this] obtain stk'' where stk': "stk' = stk'' @ v # STK"
      and exec''': "exec_meth_d (compP2 P) (compE2 i) (compxE2 i 0 0) t h (stk, loc, pc, xcp) ta h' (stk'', loc', pc' - length (compE2 a), xcp')" by blast
    from exec''' have "exec_meth_d (compP2 P) ((compE2 a @ compE2 i) @ compE2 e @ [AStore, Push Unit]) ((compxE2 a 0 0 @ shift (length (compE2 a)) (stack_xlift (length [v]) (compxE2 i 0 0))) @ shift (length (compE2 a @ compE2 i)) (compxE2 e 0 (Suc (Suc 0)))) t h (stk @ [v], loc, length (compE2 a) + pc, xcp) ta h' (stk'' @ [v], loc', length (compE2 a) + (pc' - length (compE2 a)), xcp')"
      apply -
      apply(rule exec_meth_append_xt)
      apply(rule append_exec_meth_xt)
      apply(erule exec_meth_stk_offer)
      by auto
    moreover from exec'' have "pc'  length (compE2 a)"
      by(rule exec_meth_drop_xt_pc) auto
    ultimately show ?thesis using stk' by(auto simp add: shift_compxE2 stack_xlift_compxE2)
  next
    case False
    with pc have pc: "pc = length (compE2 i)" by simp
    with exec'[of arbitrary] have "pc'  length (compE2 a @ compE2 i)"
      by-(erule exec_meth_drop_xt_pc, auto simp add: shift_compxE2 stack_xlift_compxE2)
    then obtain PC where PC: "pc' = PC + length (compE2 a) + length (compE2 i)"
      by -(rule_tac PC34="pc' - length (compE2 a @ compE2 i)" in that, simp)
    from pc bisim2 obtain v' where stk: "stk = [v']" and xcp: "xcp = None" by(auto dest: bisim1_pc_length_compE2D)
    from exec'[of v'] 
    have "exec_meth_d (compP2 P) (compE2 e @ [AStore, Push Unit]) (stack_xlift (length (v' # v # STK)) (compxE2 e 0 0)) t
                    h (v' # v # STK, loc, 0, xcp) ta h' (stk', loc', pc' - length (compE2 a @ compE2 i), xcp')"
      unfolding stk pc append_Cons append_Nil
      by -(rule exec_meth_drop_xt, simp only: add_0_right length_append, auto simp add: shift_compxE2 stack_xlift_compxE2)
    with PC xcp have "?exec e [] (v' # v # STK) loc 0 None stk' loc' PC xcp'"
      by -(rule exec_meth_take,auto)
    from IH3[OF this] obtain stk'' where stk': "stk' = stk'' @ v' # v # STK"
      and "exec_meth_d (compP2 P) (compE2 e) (compxE2 e 0 0) t h ([], loc, 0, None) ta h' (stk'', loc', PC, xcp')"  by auto
    hence "exec_meth_d (compP2 P) (((compE2 a @ compE2 i) @ compE2 e) @ [AStore, Push Unit]) ((compxE2 a 0 0 @ compxE2 i (length (compE2 a)) (Suc 0)) @ shift (length (compE2 a @ compE2 i)) (stack_xlift (length [v', v]) (compxE2 e 0 0))) t h ([] @ [v', v], loc, length (compE2 a @ compE2 i) + 0, None) ta h' (stk'' @ [v', v], loc', length (compE2 a @ compE2 i) + PC, xcp')"
      apply -
      apply(rule exec_meth_append)
      apply(rule append_exec_meth_xt)
      apply(erule exec_meth_stk_offer)
      by auto
    thus ?thesis using stk xcp stk' pc PC
      by(clarsimp simp add: shift_compxE2 stack_xlift_compxE2 ac_simps)
  qed
next
  case (bisim1AAss3 e n e' xs stk loc pc xcp a i v1 v2)
  note IH3 = stk' loc' pc' xcp' STK. ?exec e stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl e stk STK loc pc xcp stk' loc' pc' xcp'
  note bisim3 = P,e,h  (e', xs)  (stk, loc, pc, xcp)
  note exec = ?exec (ai := e) (stk @ [v2, v1]) STK loc (length (compE2 a) + length (compE2 i) + pc) xcp stk' loc' pc' xcp'
  from bisim3 have pc: "pc  length (compE2 e)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e)")
    case True
    from exec have "exec_meth_d (compP2 P) (((compE2 a @ compE2 i) @ compE2 e) @ [AStore, Push Unit])
      ((compxE2 a 0 (length STK) @ compxE2 i (length (compE2 a)) (Suc (length STK))) @ shift (length (compE2 a @ compE2 i)) (stack_xlift (length (v2 # v1 # STK)) (compxE2 e 0 0))) t
      h (stk @ v2 # v1 # STK, loc, length (compE2 a @ compE2 i) + pc, xcp) ta h' (stk', loc', pc', xcp')"
      by(simp add: shift_compxE2 stack_xlift_compxE2)
    hence exec': "exec_meth_d (compP2 P) ((compE2 a @ compE2 i) @ compE2 e)
      ((compxE2 a 0 (length STK) @ compxE2 i (length (compE2 a)) (Suc (length STK))) @ shift (length (compE2 a @ compE2 i)) (stack_xlift (length (v2 # v1 # STK)) (compxE2 e 0 0))) t
      h (stk @ v2 # v1 # STK, loc, length (compE2 a @ compE2 i) + pc, xcp) ta h' (stk', loc', pc', xcp')"
      by(rule exec_meth_take)(simp add: True)
    hence "?exec e stk (v2 # v1 # STK) loc pc xcp stk' loc' (pc' - length (compE2 a @ compE2 i)) xcp'"
      by(rule exec_meth_drop_xt) auto
    from IH3[OF this] obtain stk'' where stk': "stk' = stk'' @ v2 # v1 # STK"
      and exec'': "exec_meth_d (compP2 P) (compE2 e) (compxE2 e 0 0) t h (stk, loc, pc, xcp) ta h' (stk'', loc', pc' - length (compE2 a @ compE2 i), xcp')" by blast
    from exec'' have "exec_meth_d (compP2 P) (compE2 e) (stack_xlift (length [v2, v1]) (compxE2 e 0 0)) t h (stk @ [v2, v1], loc, pc, xcp)
      ta h' (stk'' @ [v2, v1], loc', pc' - length (compE2 a @ compE2 i), xcp')"
      by(rule exec_meth_stk_offer)
    hence "exec_meth_d (compP2 P) ((compE2 a @ compE2 i) @ compE2 e) ((compxE2 a 0 0 @ compxE2 i (length (compE2 a)) (Suc 0)) @ shift (length (compE2 a @ compE2 i)) (stack_xlift (length [v2, v1]) (compxE2 e 0 0))) t
      h (stk @ [v2, v1], loc, length (compE2 a @ compE2 i) + pc, xcp)
      ta h' (stk'' @ [v2, v1], loc', length (compE2 a @ compE2 i) + (pc' - length (compE2 a @ compE2 i)), xcp')"
      by(rule append_exec_meth_xt) auto
    hence "exec_meth_d (compP2 P) (((compE2 a @ compE2 i) @ compE2 e) @ [AStore, Push Unit]) ((compxE2 a 0 0 @ compxE2 i (length (compE2 a)) (Suc 0)) @ shift (length (compE2 a @ compE2 i)) (stack_xlift (length [v2, v1]) (compxE2 e 0 0))) t
      h (stk @ [v2, v1], loc, length (compE2 a @ compE2 i) + pc, xcp)
      ta h' (stk'' @ [v2, v1], loc', length (compE2 a @ compE2 i) + (pc' - length (compE2 a @ compE2 i)), xcp')"
      by(rule exec_meth_append)
    moreover from exec' have "pc'  length (compE2 a @ compE2 i)"
      by(rule exec_meth_drop_xt_pc)(auto simp add: stack_xlift_compxE2)
    ultimately show ?thesis using stk' by(simp add: stack_xlift_compxE2 shift_compxE2)
  next
    case False
    with pc have pc: "pc = length (compE2 e)" by simp
    with bisim3 obtain v3 where [simp]: "stk = [v3]" "xcp = None"
      by(auto dest: dest: bisim1_pc_length_compE2D)
    with exec pc show ?thesis apply(simp)
      by(erule exec_meth.cases)(auto intro!: exec_meth.intros split: if_split_asm)
  qed
next
  case (bisim1AAssThrow1 A n a xs stk loc pc i e)
  note bisim1 = P,A,h  (Throw a, xs)  (stk, loc, pc, a)
  note IH1 = stk' loc' pc' xcp' STK. ?exec A stk STK loc pc a stk' loc' pc' xcp'
              ?concl A stk STK loc pc a stk' loc' pc' xcp'
  note exec = ?exec (Ai := e) stk STK loc pc a stk' loc' pc' xcp'
  from bisim1 have pc: "pc < length (compE2 A)" and [simp]: "xs = loc"
    by(auto dest: bisim1_ThrowD)
  from exec have "exec_meth_d (compP2 P) (compE2 A @ (compE2 i @ compE2 e @ [AStore, Push Unit]))
     (stack_xlift (length STK) (compxE2 A 0 0) @ shift (length (compE2 A)) (stack_xlift (length STK) (compxE2 i 0 (Suc 0) @ compxE2 e (length (compE2 i)) (Suc (Suc 0))))) t
     h (stk @ STK, loc, pc, a) ta h' (stk', loc', pc', xcp')" by(simp add: compxE2_size_convs)
  hence "?exec A stk STK loc pc a stk' loc' pc' xcp'" by(rule exec_meth_take_xt)(rule pc)
  from IH1[OF this] show ?case by(auto)
next
  case (bisim1AAssThrow2 i n a xs stk loc pc A e v1)
  note bisim2 = P,i,h  (Throw a, xs)  (stk, loc, pc, a)
  note IH2 = stk' loc' pc' xcp' STK. ?exec i stk STK loc pc a stk' loc' pc' xcp'
              ?concl i stk STK loc pc a stk' loc' pc' xcp'
  note exec = ?exec (Ai := e) (stk @ [v1]) STK loc (length (compE2 A) + pc) a stk' loc' pc' xcp'
  from bisim2 have pc: "pc < length (compE2 i)" and [simp]: "xs = loc"
    by(auto dest: bisim1_ThrowD)
  from exec have "exec_meth_d (compP2 P) ((compE2 A @ compE2 i) @ compE2 e @ [AStore, Push Unit])
     ((stack_xlift (length STK) (compxE2 A 0 0) @ shift (length (compE2 A)) (stack_xlift (length STK) (compxE2 i 0 (Suc 0)))) @ (shift (length (compE2 A @ compE2 i)) (compxE2 e 0 (Suc (Suc (length STK)))))) t
     h (stk @ v1 # STK, loc, length (compE2 A) + pc, a) ta h' (stk', loc', pc', xcp')"
    by(simp add: shift_compxE2 stack_xlift_compxE2 ac_simps)
  hence exec': "exec_meth_d (compP2 P) (compE2 A @ compE2 i)
     (stack_xlift (length STK) (compxE2 A 0 0) @ shift (length (compE2 A)) (stack_xlift (length STK) (compxE2 i 0 (Suc 0)))) t
     h (stk @ v1 # STK, loc, length (compE2 A) + pc, a) ta h' (stk', loc', pc', xcp')"
    by(rule exec_meth_take_xt)(simp add: pc)
  hence "exec_meth_d (compP2 P) (compE2 i) (stack_xlift (length STK) (compxE2 i 0 (Suc 0))) t
     h (stk @ v1 # STK, loc, pc, a) ta h' (stk', loc', pc' - length (compE2 A), xcp')"
    by(rule exec_meth_drop_xt)(auto simp add: stack_xlift_compxE2)
  hence "?exec i stk (v1 # STK) loc pc a stk' loc' (pc' - length (compE2 A)) xcp'"
    by(simp add: compxE2_stack_xlift_convs)
  from IH2[OF this] obtain stk'' where stk': "stk' = stk'' @ v1 # STK" and
    exec'': "exec_meth_d (compP2 P) (compE2 i) (compxE2 i 0 0) t h (stk, loc, pc, a) ta h' (stk'', loc', pc' - length (compE2 A), xcp')" by blast
  from exec'' have "exec_meth_d (compP2 P) (compE2 i) (stack_xlift (length [v1]) (compxE2 i 0 0)) t 
      h (stk @ [v1], loc, pc, a)
      ta h' (stk'' @ [v1], loc', pc' - length (compE2 A), xcp')"
    by(rule exec_meth_stk_offer)
  hence "exec_meth_d (compP2 P) (compE2 A @ compE2 i) (compxE2 A 0 0 @ shift (length (compE2 A)) (stack_xlift (length [v1]) (compxE2 i 0 0))) t 
      h (stk @ [v1], loc, length (compE2 A) + pc, a)
      ta h' (stk'' @ [v1], loc', length (compE2 A) + (pc' - length (compE2 A)), xcp')"
    by(rule append_exec_meth_xt)(auto)
  hence "exec_meth_d (compP2 P) ((compE2 A @ compE2 i) @ compE2 e @ [AStore, Push Unit]) ((compxE2 A 0 0 @ shift (length (compE2 A)) (stack_xlift (length [v1]) (compxE2 i 0 0))) @ (shift (length (compE2 A @ compE2 i)) (compxE2 e 0 (Suc (Suc 0))))) t
      h (stk @ [v1], loc, length (compE2 A) + pc, a)
      ta h' (stk'' @ [v1], loc', length (compE2 A) + (pc' - length (compE2 A)), xcp')"
    by(rule exec_meth_append_xt)
  moreover from exec' have pc': "pc'  length (compE2 A)"
    by(rule exec_meth_drop_xt_pc)(auto simp add: stack_xlift_compxE2)
  ultimately show ?case using stk' by(auto simp add: stack_xlift_compxE2 shift_compxE2)
next
  case (bisim1AAssThrow3 e n a xs stk loc pc A i v2 v1)
  note bisim3 = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  note IH3 = stk' loc' pc' xcp' STK. ?exec e stk STK loc pc a stk' loc' pc' xcp'
              ?concl e stk STK loc pc a stk' loc' pc' xcp'
  note exec = ?exec (Ai := e) (stk @ [v2, v1]) STK loc (length (compE2 A) + length (compE2 i) + pc) a stk' loc' pc' xcp'
  from bisim3 have pc: "pc < length (compE2 e)" and [simp]: "xs = loc"
    by(auto dest: bisim1_ThrowD)
  from exec have "exec_meth_d (compP2 P) (((compE2 A @ compE2 i) @ compE2 e) @ [AStore, Push Unit])
     ((stack_xlift (length STK) (compxE2 A 0 0 @ compxE2 i (length (compE2 A)) (Suc 0))) @ shift (length (compE2 A @ compE2 i)) (stack_xlift (length (v2 # v1 # STK)) (compxE2 e 0 0))) t
     h (stk @ v2 # v1 # STK, loc, length (compE2 A @ compE2 i) + pc, a) ta h' (stk', loc', pc', xcp')"
    by(simp add: shift_compxE2 stack_xlift_compxE2 ac_simps)
  hence exec': "exec_meth_d (compP2 P) ((compE2 A @ compE2 i) @ compE2 e)
     ((stack_xlift (length STK) (compxE2 A 0 0 @ compxE2 i (length (compE2 A)) (Suc 0))) @ shift (length (compE2 A @ compE2 i)) (stack_xlift (length (v2 # v1 # STK)) (compxE2 e 0 0))) t
     h (stk @ v2 # v1 # STK, loc, length (compE2 A @ compE2 i) + pc, a) ta h' (stk', loc', pc', xcp')"
    by(rule exec_meth_take)(simp add: pc)
  hence "?exec e stk (v2 # v1 # STK) loc pc a stk' loc' (pc' - length (compE2 A @ compE2 i)) xcp'"
    by(rule exec_meth_drop_xt) auto
  from IH3[OF this] obtain stk'' where stk': "stk' = stk'' @ v2 # v1 # STK" and
    exec'': "exec_meth_d (compP2 P) (compE2 e) (compxE2 e 0 0) t h (stk, loc, pc, a) ta h' (stk'', loc', pc' - length (compE2 A @ compE2 i), xcp')" by blast
  from exec'' have "exec_meth_d (compP2 P) (compE2 e) (stack_xlift (length [v2, v1]) (compxE2 e 0 0)) t h (stk @ [v2, v1], loc, pc, a)
      ta h' (stk'' @ [v2, v1], loc', pc' - length (compE2 A @ compE2 i), xcp')"
    by(rule exec_meth_stk_offer)
  hence "exec_meth_d (compP2 P) ((compE2 A @ compE2 i) @ compE2 e) ((compxE2 A 0 0 @ compxE2 i (length (compE2 A)) (Suc 0)) @ shift (length (compE2 A @ compE2 i)) (stack_xlift (length [v2, v1]) (compxE2 e 0 0))) t h (stk @ [v2, v1], loc, length (compE2 A @ compE2 i) + pc, a)
      ta h' (stk'' @ [v2, v1], loc', length (compE2 A @ compE2 i) + (pc' - length (compE2 A @ compE2 i)), xcp')"
    by(rule append_exec_meth_xt)(auto)
  hence "exec_meth_d (compP2 P) (((compE2 A @ compE2 i) @ compE2 e) @ [AStore, Push Unit]) ((compxE2 A 0 0 @ compxE2 i (length (compE2 A)) (Suc 0)) @ shift (length (compE2 A @ compE2 i)) (stack_xlift (length [v2, v1]) (compxE2 e 0 0))) t h (stk @ [v2, v1], loc, length (compE2 A @ compE2 i) + pc, a)
      ta h' (stk'' @ [v2, v1], loc', length (compE2 A @ compE2 i) + (pc' - length (compE2 A @ compE2 i)), xcp')"
    by(rule exec_meth_append)
  moreover from exec' have pc': "pc'  length (compE2 A @ compE2 i)"
    by(rule exec_meth_drop_xt_pc)(auto simp add: stack_xlift_compxE2)
  ultimately show ?case using stk' by(auto simp add: stack_xlift_compxE2 shift_compxE2)
next
  case bisim1AAssFail thus ?case
    by(auto elim!: exec_meth.cases dest: match_ex_table_pcsD simp add: stack_xlift_compxEs2 stack_xlift_compxE2)
next
  case bisim1AAss4 thus ?case
    by -(erule exec_meth.cases, auto intro!: exec_meth.exec_instr)
next
  case (bisim1ALength a n a' xs stk loc pc xcp)
  note bisim = P,a,h  (a', xs)  (stk, loc, pc, xcp)
  note IH = stk' loc' pc' xcp' STK. ?exec a stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl a stk STK loc pc xcp stk' loc' pc' xcp'
  note exec = ?exec (a∙length) stk STK loc pc xcp stk' loc' pc' xcp'
  from bisim have pc: "pc  length (compE2 a)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 a)")
    case True
    with exec have "?exec a stk STK loc pc xcp stk' loc' pc' xcp'"
      by(simp add: compxE2_size_convs)(erule exec_meth_take)
    from IH[OF this] show ?thesis by auto
  next
    case False
    with pc have [simp]: "pc = length (compE2 a)" by simp
    with bisim obtain v where [simp]: "stk = [v]" "xcp = None"
      by(auto dest: dest: bisim1_pc_length_compE2D)
    with exec show ?thesis apply(simp)
      by(erule exec_meth.cases)(auto intro!: exec_meth.intros split: if_split_asm)
  qed
next
  case (bisim1ALengthThrow e n a xs stk loc pc)
  note bisim = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  note IH = stk' loc' pc' xcp' STK. ?exec e stk STK loc pc a stk' loc' pc' xcp'
              ?concl e stk STK loc pc a stk' loc' pc' xcp'
  note exec = ?exec (e∙length) stk STK loc pc a stk' loc' pc' xcp'
  from bisim have pc: "pc < length (compE2 e)" and [simp]: "xs = loc"
    by(auto dest: bisim1_ThrowD)
  from exec have "?exec e stk STK loc pc a stk' loc' pc' xcp'"
    by(simp)(erule exec_meth_take[OF _ pc])
  from IH[OF this] show ?case by(auto)
next
  case bisim1ALengthNull thus ?case
    by(auto elim!: exec_meth.cases dest: match_ex_table_pcsD simp add: stack_xlift_compxEs2 stack_xlift_compxE2)
next
  case (bisim1FAcc e n e' xs stk loc pc xcp F D)
  note bisim = P,e,h  (e', xs)  (stk, loc, pc, xcp)
  note IH = stk' loc' pc' xcp' STK. ?exec e stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl e stk STK loc pc xcp stk' loc' pc' xcp'
  note exec = ?exec (eF{D}) stk STK loc pc xcp stk' loc' pc' xcp'
  from bisim have pc: "pc  length (compE2 e)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e)")
    case True
    with exec have "?exec e stk STK loc pc xcp stk' loc' pc' xcp'"
      by(simp add: compxE2_size_convs)(erule exec_meth_take)
    from IH[OF this] show ?thesis by auto
  next
    case False
    with pc have [simp]: "pc = length (compE2 e)" by simp
    with bisim obtain v where [simp]: "stk = [v]" "xcp = None"
      by(auto dest: dest: bisim1_pc_length_compE2D)
    with exec show ?thesis apply(simp)
      by(erule exec_meth.cases)(fastforce intro!: exec_meth.intros simp add: is_Ref_def split: if_split_asm)+
  qed
next
  case (bisim1FAccThrow e n a xs stk loc pc F D)
  note bisim = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  note IH = stk' loc' pc' xcp' STK. ?exec e stk STK loc pc a stk' loc' pc' xcp'
              ?concl e stk STK loc pc a stk' loc' pc' xcp'
  note exec = ?exec (eF{D}) stk STK loc pc a stk' loc' pc' xcp'
  from bisim have pc: "pc < length (compE2 e)" and [simp]: "xs = loc"
    by(auto dest: bisim1_ThrowD)
  from exec have "?exec e stk STK loc pc a stk' loc' pc' xcp'"
    by(simp)(erule exec_meth_take[OF _ pc])
  from IH[OF this] show ?case by(auto)
next
  case bisim1FAccNull thus ?case
    by(auto elim!: exec_meth.cases dest: match_ex_table_pcsD simp add: stack_xlift_compxEs2 stack_xlift_compxE2)
next
  case (bisim1FAss1 e n e' xs stk loc pc xcp e2 F D)
  note IH1 = stk' loc' pc' xcp' STK. ?exec e stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl e stk STK loc pc xcp stk' loc' pc' xcp'
  note IH2 = xs stk' loc' pc' xcp' STK. ?exec e2 [] STK xs 0 None stk' loc' pc' xcp'
              ?concl e2 [] STK xs 0 None stk' loc' pc' xcp'
  note bisim1 = P,e,h  (e', xs)  (stk, loc, pc, xcp)
  note bisim2 = P,e2,h  (e2, loc)  ([], loc, 0, None)
  note exec = ?exec (eF{D} := e2) stk STK loc pc xcp stk' loc' pc' xcp'
  from bisim1 have pc: "pc  length (compE2 e)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e)")
    case True
    with exec have "?exec e stk STK loc pc xcp stk' loc' pc' xcp'"
      by(simp add: compxE2_size_convs)(erule exec_meth_take_xt)
    from IH1[OF this] show ?thesis by auto
  next
    case False
    with pc have pc: "pc = length (compE2 e)" by simp
    with exec have "pc'  length (compE2 e)"
      by(simp add: compxE2_size_convs stack_xlift_compxE2)(auto elim!: exec_meth_drop_xt_pc)
    then obtain PC where PC: "pc' = PC + length (compE2 e)"
      by -(rule_tac PC34="pc' - length (compE2 e)" in that, simp)
    from pc bisim1 obtain v where "stk = [v]" "xcp = None" by(auto dest: bisim1_pc_length_compE2D)
    with exec pc have "exec_meth_d (compP2 P) (compE2 e @ compE2 e2)
      (stack_xlift (length STK) (compxE2 e 0 0 @ compxE2 e2 (length (compE2 e)) (Suc 0))) t 
      h (stk @ STK, loc, length (compE2 e) + 0, xcp) ta h' (stk', loc', pc', xcp')"
      by-(rule exec_meth_take, auto)
    hence "?exec e2 [] (v # STK) loc 0 None stk' loc' (pc' - length (compE2 e)) xcp'"
      using stk = [v] xcp = None›
      by -(rule exec_meth_drop_xt, auto simp add: stack_xlift_compxE2 shift_compxE2)
    from IH2[OF this] PC obtain stk'' where stk': "stk' = stk'' @ v # STK"
      and "exec_meth_d (compP2 P) (compE2 e2) (compxE2 e2 0 0) t h ([], loc, 0, None) ta h' (stk'', loc', PC, xcp')" by auto
    hence "exec_meth_d (compP2 P) ((compE2 e @ compE2 e2) @ [Putfield F D, Push Unit])
        (compxE2 e 0 0 @ shift (length (compE2 e)) (stack_xlift (length [v]) (compxE2 e2 0 0))) t h
        ([] @ [v], loc, length (compE2 e) + 0, None) ta h' (stk'' @ [v], loc', length (compE2 e) + PC, xcp')"
      apply -
      apply(rule exec_meth_append)
      apply(rule append_exec_meth_xt)
      apply(erule exec_meth_stk_offer)
      by(auto)
    thus ?thesis using stk = [v] xcp = None› stk' pc PC
      by(clarsimp simp add: shift_compxE2 stack_xlift_compxE2 ac_simps)
  qed
next
  case (bisim1FAss2 e2 n e' xs stk loc pc xcp e F D v1)
  note IH2 = stk' loc' pc' xcp' STK. ?exec e2 stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl e2 stk STK loc pc xcp stk' loc' pc' xcp'
  note bisim2 = P,e2,h  (e', xs)  (stk, loc, pc, xcp)
  note exec = ?exec (eF{D} := e2) (stk @ [v1]) STK loc (length (compE2 e) + pc) xcp stk' loc' pc' xcp'
  from bisim2 have pc: "pc  length (compE2 e2)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e2)")
    case True
    from exec have "exec_meth_d (compP2 P) ((compE2 e @ compE2 e2) @ [Putfield F D, Push Unit])
      (stack_xlift (length STK) (compxE2 e 0 0) @ shift (length (compE2 e)) (stack_xlift (length STK) (compxE2 e2 0 (Suc 0)))) t
      h (stk @ v1 # STK, loc, length (compE2 e) + pc, xcp) ta h' (stk', loc', pc', xcp')" by(simp add: compxE2_size_convs)
    hence exec': "exec_meth_d (compP2 P) (compE2 e @ compE2 e2) (stack_xlift (length STK) (compxE2 e 0 0) @
      shift (length (compE2 e)) (stack_xlift (length STK) (compxE2 e2 0 (Suc 0)))) t
      h (stk @ v1 # STK, loc, length (compE2 e) + pc, xcp) ta h' (stk', loc', pc', xcp')"
      by(rule exec_meth_take)(simp add: True)
    hence "exec_meth_d (compP2 P) (compE2 e2) (stack_xlift (length STK) (compxE2 e2 0 (Suc 0))) t
      h (stk @ v1 # STK, loc, pc, xcp) ta h' (stk', loc', pc' - length (compE2 e), xcp')"
      by(rule exec_meth_drop_xt)(auto simp add: stack_xlift_compxE2)
    hence "?exec e2 stk (v1 # STK) loc pc xcp stk' loc' (pc' - length (compE2 e)) xcp'"
      by(simp add: compxE2_stack_xlift_convs)
    from IH2[OF this] obtain stk'' where stk': "stk' = stk'' @ v1 # STK"
      and exec'': "exec_meth_d (compP2 P) (compE2 e2) (compxE2 e2 0 0) t h (stk, loc, pc, xcp) ta h' (stk'', loc', pc' - length (compE2 e), xcp')" by blast
    from exec'' have "exec_meth_d (compP2 P) (compE2 e2) (stack_xlift (length [v1]) (compxE2 e2 0 0)) t h (stk @ [v1], loc, pc, xcp)
      ta h' (stk'' @ [v1], loc', pc' - length (compE2 e), xcp')"
      by(rule exec_meth_stk_offer)
    hence "exec_meth_d (compP2 P) (compE2 e @ compE2 e2) (compxE2 e 0 0 @ shift (length (compE2 e)) (stack_xlift (length [v1]) (compxE2 e2 0 0))) t h (stk @ [v1], loc, length (compE2 e) + pc, xcp)
      ta h' (stk'' @ [v1], loc', length (compE2 e) + (pc' - length (compE2 e)), xcp')"
      by(rule append_exec_meth_xt) auto
    hence "exec_meth_d (compP2 P) ((compE2 e @ compE2 e2) @ [Putfield F D, Push Unit]) (compxE2 e 0 0 @ shift (length (compE2 e)) (stack_xlift (length [v1]) (compxE2 e2 0 0))) t h (stk @ [v1], loc, length (compE2 e) + pc, xcp)
      ta h' (stk'' @ [v1], loc', length (compE2 e) + (pc' - length (compE2 e)), xcp')"
      by(rule exec_meth_append)
    moreover from exec' have "pc'  length (compE2 e)"
      by(rule exec_meth_drop_xt_pc)(auto simp add: stack_xlift_compxE2)
    ultimately show ?thesis using stk' by(simp add: stack_xlift_compxE2 shift_compxE2)
  next
    case False
    with pc have pc: "pc = length (compE2 e2)" by simp
    with bisim2 obtain v2 where [simp]: "stk = [v2]" "xcp = None"
      by(auto dest: dest: bisim1_pc_length_compE2D)
    with exec pc show ?thesis apply(simp)
      by(erule exec_meth.cases)(fastforce intro!: exec_meth.intros split: if_split_asm)+
  qed
next
  case (bisim1FAssThrow1 e n a xs stk loc pc e2 F D)
  note bisim1 = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  note IH1 = stk' loc' pc' xcp' STK. ?exec e stk STK loc pc a stk' loc' pc' xcp'
              ?concl e stk STK loc pc a stk' loc' pc' xcp'
  note exec = ?exec (eF{D} := e2) stk STK loc pc a stk' loc' pc' xcp'
  from bisim1 have pc: "pc < length (compE2 e)" and [simp]: "xs = loc"
    by(auto dest: bisim1_ThrowD)
  from exec have "exec_meth_d (compP2 P) (compE2 e @ (compE2 e2 @ [Putfield F D, Push Unit]))
     (stack_xlift (length STK) (compxE2 e 0 0) @ shift (length (compE2 e)) (stack_xlift (length STK) (compxE2 e2 0 (Suc 0)))) t
     h (stk @ STK, loc, pc, a) ta h' (stk', loc', pc', xcp')" by(simp add: compxE2_size_convs)
  hence "?exec e stk STK loc pc a stk' loc' pc' xcp'" by(rule exec_meth_take_xt)(rule pc)
  from IH1[OF this] show ?case by(auto)
next
  case (bisim1FAssThrow2 e2 n a xs stk loc pc e F D v1)
  note bisim2 = P,e2,h  (Throw a, xs)  (stk, loc, pc, a)
  note IH2 = stk' loc' pc' xcp' STK. ?exec e2 stk STK loc pc a stk' loc' pc' xcp'
              ?concl e2 stk STK loc pc a stk' loc' pc' xcp'
  note exec = ?exec (eF{D} := e2) (stk @ [v1]) STK loc (length (compE2 e) + pc) a stk' loc' pc' xcp'
  from bisim2 have pc: "pc < length (compE2 e2)" and [simp]: "xs = loc"
    by(auto dest: bisim1_ThrowD)
  from exec have "exec_meth_d (compP2 P) ((compE2 e @ compE2 e2) @ [Putfield F D, Push Unit])
     (stack_xlift (length STK) (compxE2 e 0 0) @ shift (length (compE2 e)) (stack_xlift (length STK) (compxE2 e2 0 (Suc 0)))) t
     h (stk @ v1 # STK, loc, length (compE2 e) + pc, a) ta h' (stk', loc', pc', xcp')"
    by(simp add: compxE2_size_convs)
  hence exec': "exec_meth_d (compP2 P) (compE2 e @ compE2 e2)
     (stack_xlift (length STK) (compxE2 e 0 0) @ shift (length (compE2 e)) (stack_xlift (length STK) (compxE2 e2 0 (Suc 0)))) t
     h (stk @ v1 # STK, loc, length (compE2 e) + pc, a) ta h' (stk', loc', pc', xcp')"
    by(rule exec_meth_take)(simp add: pc)
  hence "exec_meth_d (compP2 P) (compE2 e2) (stack_xlift (length STK) (compxE2 e2 0 (Suc 0))) t
     h (stk @ v1 # STK, loc, pc, a) ta h' (stk', loc', pc' - length (compE2 e), xcp')"
    by(rule exec_meth_drop_xt)(auto simp add: stack_xlift_compxE2)
  hence "?exec e2 stk (v1 # STK) loc pc a stk' loc' (pc' - length (compE2 e)) xcp'"
    by(simp add: compxE2_stack_xlift_convs)
  from IH2[OF this] obtain stk'' where stk': "stk' = stk'' @ v1 # STK" and
    exec'': "exec_meth_d (compP2 P) (compE2 e2) (compxE2 e2 0 0) t h (stk, loc, pc, a) ta h' (stk'', loc', pc' - length (compE2 e), xcp')" by blast
  from exec'' have "exec_meth_d (compP2 P) (compE2 e2) (stack_xlift (length [v1]) (compxE2 e2 0 0)) t h (stk @ [v1], loc, pc, a)
      ta h' (stk'' @ [v1], loc', pc' - length (compE2 e), xcp')"
    by(rule exec_meth_stk_offer)
  hence "exec_meth_d (compP2 P) (compE2 e @ compE2 e2) (compxE2 e 0 0 @ shift (length (compE2 e)) (stack_xlift (length [v1]) (compxE2 e2 0 0))) t h (stk @ [v1], loc, length (compE2 e) + pc, a)
      ta h' (stk'' @ [v1], loc', length (compE2 e) + (pc' - length (compE2 e)), xcp')"
    by(rule append_exec_meth_xt)(auto)
  hence "exec_meth_d (compP2 P) ((compE2 e @ compE2 e2) @ [Putfield F D, Push Unit]) (compxE2 e 0 0 @ shift (length (compE2 e)) (stack_xlift (length [v1]) (compxE2 e2 0 0))) t h (stk @ [v1], loc, length (compE2 e) + pc, a)
      ta h' (stk'' @ [v1], loc', length (compE2 e) + (pc' - length (compE2 e)), xcp')"
    by(rule exec_meth_append)
  moreover from exec' have pc': "pc'  length (compE2 e)"
    by(rule exec_meth_drop_xt_pc)(auto simp add: stack_xlift_compxE2)
  ultimately show ?case using stk' by(auto simp add: stack_xlift_compxE2 shift_compxE2)
next
  case bisim1FAssNull thus ?case
    by(auto elim!: exec_meth.cases dest: match_ex_table_pcsD simp add: stack_xlift_compxEs2 stack_xlift_compxE2)
next
  case bisim1FAss3 thus ?case
    by -(erule exec_meth.cases, auto intro!: exec_meth.exec_instr)
next
  case (bisim1CAS1 e1 n e1' xs stk loc pc xcp e2 e3 D F)
  note IH1 = stk' loc' pc' xcp' STK. ?exec e1 stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl e1 stk STK loc pc xcp stk' loc' pc' xcp'
  note IH2 = xs stk' loc' pc' xcp' STK. ?exec e2 [] STK xs 0 None stk' loc' pc' xcp'
              ?concl e2 [] STK xs 0 None stk' loc' pc' xcp'
  note bisim1 = P,e1,h  (e1', xs)  (stk, loc, pc, xcp)
  note bisim2 = P,e2,h  (e2, loc)  ([], loc, 0, None)
  note exec = ?exec _ stk STK loc pc xcp stk' loc' pc' xcp'
  from bisim1 have pc: "pc  length (compE2 e1)" by(rule bisim1_pc_length_compE2)
  from exec have exec': "exec_meth_d (compP2 P) (compE2 e1 @ compE2 e2 @ compE2 e3 @ [CAS F D]) (stack_xlift (length STK) (compxE2 e1 0 0) @ shift (length (compE2 e1)) (stack_xlift (length STK) (compxE2 e2 0 (Suc 0) @ compxE2 e3 (length (compE2 e2)) (Suc (Suc 0))))) t
    h (stk @ STK, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
    by(simp add: compxE2_size_convs)
  show ?case
  proof(cases "pc < length (compE2 e1)")
    case True
    with exec' have "?exec e1 stk STK loc pc xcp stk' loc' pc' xcp'" by(rule exec_meth_take_xt)
    from IH1[OF this] show ?thesis by auto
  next
    case False
    with pc have pc: "pc = length (compE2 e1)" by simp
    with exec' have "pc'  length (compE2 e1)" by -(erule exec_meth_drop_xt_pc, auto)
    then obtain PC where PC: "pc' = PC + length (compE2 e1)"
      by -(rule_tac PC34="pc' - length (compE2 e1)" in that, simp)
    from pc bisim1 obtain v where "stk = [v]" "xcp = None" by(auto dest: bisim1_pc_length_compE2D)
    with exec PC pc
    have "exec_meth_d (compP2 P) ((compE2 e1 @ compE2 e2) @ compE2 e3 @ [CAS F D]) (stack_xlift (length STK) (compxE2 e1 0 0 @ shift (length (compE2 e1)) (compxE2 e2 0 (Suc 0))) @ shift (length (compE2 e1 @ compE2 e2)) (compxE2 e3 0 (length STK + Suc (Suc 0)))) t
    h (v # STK, loc, length (compE2 e1) + 0, None) ta h' (stk', loc', length (compE2 e1) + PC, xcp')" 
      by(simp add: shift_compxE2 stack_xlift_compxE2 ac_simps)
    hence "exec_meth_d (compP2 P) (compE2 e1 @ compE2 e2)
   (stack_xlift (length STK) (compxE2 e1 0 0 @ shift (length (compE2 e1)) (compxE2 e2 0 (Suc 0)))) t h (v # STK, loc, length (compE2 e1) + 0, None) ta h' (stk', loc', length (compE2 e1) + PC, xcp')"
      by(rule exec_meth_take_xt) simp
    hence "?exec e2 [] (v # STK) loc 0 None stk' loc' ((length (compE2 e1) + PC) - length (compE2 e1)) xcp'"
      by -(rule exec_meth_drop_xt, auto simp add: stack_xlift_compxE2 shift_compxE2)
    from IH2[OF this] PC obtain stk'' where stk': "stk' = stk'' @ v # STK"
      and "exec_meth_d (compP2 P) (compE2 e2) (compxE2 e2 0 0) t h ([], loc, 0, None) ta h' (stk'', loc', PC, xcp')" by auto
    hence "exec_meth_d (compP2 P) ((compE2 e1 @ compE2 e2) @ (compE2 e3 @ [CAS F D]))
        ((compxE2 e1 0 0 @ shift (length (compE2 e1)) (stack_xlift (length [v]) (compxE2 e2 0 0))) @
         shift (length (compE2 e1 @ compE2 e2)) (compxE2 e3 0 (Suc (Suc 0)))) t h
        ([] @ [v], loc, length (compE2 e1) + 0, None) ta h' (stk'' @ [v], loc', length (compE2 e1) + PC, xcp')"
      apply -
      apply(rule exec_meth_append_xt)
      apply(rule append_exec_meth_xt)
      apply(erule exec_meth_stk_offer)
      by(auto)
    thus ?thesis using stk = [v] xcp = None› stk' pc PC
      by(clarsimp simp add: shift_compxE2 stack_xlift_compxE2 ac_simps)
  qed
next
  case (bisim1CAS2 e2 n e2' xs stk loc pc xcp e1 e3 D F v)
  note IH2 = stk' loc' pc' xcp' STK. ?exec e2 stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl e2 stk STK loc pc xcp stk' loc' pc' xcp'
  note IH3 = xs stk' loc' pc' xcp' STK. ?exec e3 [] STK xs 0 None stk' loc' pc' xcp'
              ?concl e3 [] STK xs 0 None stk' loc' pc' xcp'
  note bisim2 = P,e2,h  (e2', xs)  (stk, loc, pc, xcp)
  note bisim3 = P,e3,h  (e3, loc)  ([], loc, 0, None)
  note exec = ?exec _ (stk @ [v]) STK loc (length (compE2 e1) + pc) xcp stk' loc' pc' xcp'
  from bisim2 have pc: "pc  length (compE2 e2)" by(rule bisim1_pc_length_compE2)
  from exec have exec': "v'. exec_meth_d (compP2 P) ((compE2 e1 @ compE2 e2) @ compE2 e3 @ [CAS F D]) ((compxE2 e1 0 (length STK) @ shift (length (compE2 e1)) (stack_xlift (length (v # STK)) (compxE2 e2 0 0))) @ shift (length (compE2 e1 @ compE2 e2)) (stack_xlift (length (v' # v # STK)) (compxE2 e3 0 0))) t
    h (stk @ v # STK, loc, length (compE2 e1) + pc, xcp) ta h' (stk', loc', pc', xcp')"
    by(simp add: shift_compxE2 stack_xlift_compxE2)
  show ?case
  proof(cases "pc < length (compE2 e2)")
    case True with exec'[of undefined]
    have exec'': "exec_meth_d (compP2 P) (compE2 e1 @ compE2 e2) (compxE2 e1 0 (length STK) @ shift (length (compE2 e1)) (stack_xlift (length (v # STK)) (compxE2 e2 0 0))) t h (stk @ v # STK, loc, length (compE2 e1) + pc, xcp) ta h' (stk', loc', pc', xcp')"
      by-(erule exec_meth_take_xt, simp)
    hence "?exec e2 stk (v # STK) loc pc xcp stk' loc' (pc' - length (compE2 e1)) xcp'"
      by(rule exec_meth_drop_xt) auto
    from IH2[OF this] obtain stk'' where stk': "stk' = stk'' @ v # STK"
      and exec''': "exec_meth_d (compP2 P) (compE2 e2) (compxE2 e2 0 0) t h (stk, loc, pc, xcp) ta h' (stk'', loc', pc' - length (compE2 e1), xcp')" by blast
    from exec''' have "exec_meth_d (compP2 P) ((compE2 e1 @ compE2 e2) @ compE2 e3 @ [CAS F D]) ((compxE2 e1 0 0 @ shift (length (compE2 e1)) (stack_xlift (length [v]) (compxE2 e2 0 0))) @ shift (length (compE2 e1 @ compE2 e2)) (compxE2 e3 0 (Suc (Suc 0)))) t h (stk @ [v], loc, length (compE2 e1) + pc, xcp) ta h' (stk'' @ [v], loc', length (compE2 e1) + (pc' - length (compE2 e1)), xcp')"
      apply -
      apply(rule exec_meth_append_xt)
      apply(rule append_exec_meth_xt)
      apply(erule exec_meth_stk_offer)
      by auto
    moreover from exec'' have "pc'  length (compE2 e1)"
      by(rule exec_meth_drop_xt_pc) auto
    ultimately show ?thesis using stk' by(auto simp add: shift_compxE2 stack_xlift_compxE2)
  next
    case False
    with pc have pc: "pc = length (compE2 e2)" by simp
    with exec'[of undefined] have "pc'  length (compE2 e1 @ compE2 e2)"
      by-(erule exec_meth_drop_xt_pc, auto simp add: shift_compxE2 stack_xlift_compxE2)
    then obtain PC where PC: "pc' = PC + length (compE2 e1) + length (compE2 e2)"
      by -(rule_tac PC34="pc' - length (compE2 e1 @ compE2 e2)" in that, simp)
    from pc bisim2 obtain v' where stk: "stk = [v']" and xcp: "xcp = None" by(auto dest: bisim1_pc_length_compE2D)
    from exec'[of v'] 
    have "exec_meth_d (compP2 P) (compE2 e3 @ [CAS F D]) (stack_xlift (length (v' # v # STK)) (compxE2 e3 0 0)) t
                    h (v' # v # STK, loc, 0, xcp) ta h' (stk', loc', pc' - length (compE2 e1 @ compE2 e2), xcp')"
      unfolding stk pc append_Cons append_Nil
      by -(rule exec_meth_drop_xt, simp only: add_0_right length_append, auto simp add: shift_compxE2 stack_xlift_compxE2)
    with PC xcp have "?exec e3 [] (v' # v # STK) loc 0 None stk' loc' PC xcp'"
      by -(rule exec_meth_take,auto)
    from IH3[OF this] obtain stk'' where stk': "stk' = stk'' @ v' # v # STK"
      and "exec_meth_d (compP2 P) (compE2 e3) (compxE2 e3 0 0) t h ([], loc, 0, None) ta h' (stk'', loc', PC, xcp')"  by auto
    hence "exec_meth_d (compP2 P) (((compE2 e1 @ compE2 e2) @ compE2 e3) @ [CAS F D]) ((compxE2 e1 0 0 @ compxE2 e2 (length (compE2 e1)) (Suc 0)) @ shift (length (compE2 e1 @ compE2 e2)) (stack_xlift (length [v', v]) (compxE2 e3 0 0))) t h ([] @ [v', v], loc, length (compE2 e1 @ compE2 e2) + 0, None) ta h' (stk'' @ [v', v], loc', length (compE2 e1 @ compE2 e2) + PC, xcp')"
      apply -
      apply(rule exec_meth_append)
      apply(rule append_exec_meth_xt)
      apply(erule exec_meth_stk_offer)
      by auto
    thus ?thesis using stk xcp stk' pc PC
      by(clarsimp simp add: shift_compxE2 stack_xlift_compxE2 ac_simps)
  qed
next
  case (bisim1CAS3 e3 n e3' xs stk loc pc xcp e1 e2 D F v1 v2)
  note IH3 = stk' loc' pc' xcp' STK. ?exec e3 stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl e3 stk STK loc pc xcp stk' loc' pc' xcp'
  note bisim3 = P,e3,h  (e3', xs)  (stk, loc, pc, xcp)
  note exec = ?exec _ (stk @ [v2, v1]) STK loc (length (compE2 e1) + length (compE2 e2) + pc) xcp stk' loc' pc' xcp'
  from bisim3 have pc: "pc  length (compE2 e3)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e3)")
    case True
    from exec have "exec_meth_d (compP2 P) (((compE2 e1 @ compE2 e2) @ compE2 e3) @ [CAS F D])
      ((compxE2 e1 0 (length STK) @ compxE2 e2 (length (compE2 e1)) (Suc (length STK))) @ shift (length (compE2 e1 @ compE2 e2)) (stack_xlift (length (v2 # v1 # STK)) (compxE2 e3 0 0))) t
      h (stk @ v2 # v1 # STK, loc, length (compE2 e1 @ compE2 e2) + pc, xcp) ta h' (stk', loc', pc', xcp')"
      by(simp add: shift_compxE2 stack_xlift_compxE2)
    hence exec': "exec_meth_d (compP2 P) ((compE2 e1 @ compE2 e2) @ compE2 e3)
      ((compxE2 e1 0 (length STK) @ compxE2 e2 (length (compE2 e1)) (Suc (length STK))) @ shift (length (compE2 e1 @ compE2 e2)) (stack_xlift (length (v2 # v1 # STK)) (compxE2 e3 0 0))) t
      h (stk @ v2 # v1 # STK, loc, length (compE2 e1 @ compE2 e2) + pc, xcp) ta h' (stk', loc', pc', xcp')"
      by(rule exec_meth_take)(simp add: True)
    hence "?exec e3 stk (v2 # v1 # STK) loc pc xcp stk' loc' (pc' - length (compE2 e1 @ compE2 e2)) xcp'"
      by(rule exec_meth_drop_xt) auto
    from IH3[OF this] obtain stk'' where stk': "stk' = stk'' @ v2 # v1 # STK"
      and exec'': "exec_meth_d (compP2 P) (compE2 e3) (compxE2 e3 0 0) t h (stk, loc, pc, xcp) ta h' (stk'', loc', pc' - length (compE2 e1 @ compE2 e2), xcp')" by blast
    from exec'' have "exec_meth_d (compP2 P) (compE2 e3) (stack_xlift (length [v2, v1]) (compxE2 e3 0 0)) t h (stk @ [v2, v1], loc, pc, xcp)
      ta h' (stk'' @ [v2, v1], loc', pc' - length (compE2 e1 @ compE2 e2), xcp')"
      by(rule exec_meth_stk_offer)
    hence "exec_meth_d (compP2 P) ((compE2 e1 @ compE2 e2) @ compE2 e3) ((compxE2 e1 0 0 @ compxE2 e2 (length (compE2 e1)) (Suc 0)) @ shift (length (compE2 e1 @ compE2 e2)) (stack_xlift (length [v2, v1]) (compxE2 e3 0 0))) t
      h (stk @ [v2, v1], loc, length (compE2 e1 @ compE2 e2) + pc, xcp)
      ta h' (stk'' @ [v2, v1], loc', length (compE2 e1 @ compE2 e2) + (pc' - length (compE2 e1 @ compE2 e2)), xcp')"
      by(rule append_exec_meth_xt) auto
    hence "exec_meth_d (compP2 P) (((compE2 e1 @ compE2 e2) @ compE2 e3) @ [CAS F D]) ((compxE2 e1 0 0 @ compxE2 e2 (length (compE2 e1)) (Suc 0)) @ shift (length (compE2 e1 @ compE2 e2)) (stack_xlift (length [v2, v1]) (compxE2 e3 0 0))) t
      h (stk @ [v2, v1], loc, length (compE2 e1 @ compE2 e2) + pc, xcp)
      ta h' (stk'' @ [v2, v1], loc', length (compE2 e1 @ compE2 e2) + (pc' - length (compE2 e1 @ compE2 e2)), xcp')"
      by(rule exec_meth_append)
    moreover from exec' have "pc'  length (compE2 e1 @ compE2 e2)"
      by(rule exec_meth_drop_xt_pc)(auto simp add: stack_xlift_compxE2)
    ultimately show ?thesis using stk' by(simp add: stack_xlift_compxE2 shift_compxE2)
  next
    case False
    with pc have pc: "pc = length (compE2 e3)" by simp
    with bisim3 obtain v3 where [simp]: "stk = [v3]" "xcp = None"
      by(auto dest: dest: bisim1_pc_length_compE2D)
    with exec pc show ?thesis apply(simp)
      by(erule exec_meth.cases)(fastforce intro!: exec_meth.intros split: if_split_asm)+
  qed
next
  case (bisim1CASThrow1 e1 n a xs stk loc pc e2 e3 D F)
  note bisim1 = P,e1,h  (Throw a, xs)  (stk, loc, pc, a)
  note IH1 = stk' loc' pc' xcp' STK. ?exec e1 stk STK loc pc a stk' loc' pc' xcp'
              ?concl e1 stk STK loc pc a stk' loc' pc' xcp'
  note exec = ?exec _ stk STK loc pc a stk' loc' pc' xcp'
  from bisim1 have pc: "pc < length (compE2 e1)" and [simp]: "xs = loc"
    by(auto dest: bisim1_ThrowD)
  from exec have "exec_meth_d (compP2 P) (compE2 e1 @ (compE2 e2 @ compE2 e3 @ [CAS F D]))
     (stack_xlift (length STK) (compxE2 e1 0 0) @ shift (length (compE2 e1)) (stack_xlift (length STK) (compxE2 e2 0 (Suc 0) @ compxE2 e3 (length (compE2 e2)) (Suc (Suc 0))))) t
     h (stk @ STK, loc, pc, a) ta h' (stk', loc', pc', xcp')" by(simp add: compxE2_size_convs)
  hence "?exec e1 stk STK loc pc a stk' loc' pc' xcp'" by(rule exec_meth_take_xt)(rule pc)
  from IH1[OF this] show ?case by(auto)
next
  case (bisim1CASThrow2 e2 n a xs stk loc pc e1 e3 D F v1)
  note bisim2 = P,e2,h  (Throw a, xs)  (stk, loc, pc, a)
  note IH2 = stk' loc' pc' xcp' STK. ?exec e2 stk STK loc pc a stk' loc' pc' xcp'
              ?concl e2 stk STK loc pc a stk' loc' pc' xcp'
  note exec = ?exec _ (stk @ [v1]) STK loc (length (compE2 e1) + pc) a stk' loc' pc' xcp'
  from bisim2 have pc: "pc < length (compE2 e2)" and [simp]: "xs = loc"
    by(auto dest: bisim1_ThrowD)
  from exec have "exec_meth_d (compP2 P) ((compE2 e1 @ compE2 e2) @ compE2 e3 @ [CAS F D])
     ((stack_xlift (length STK) (compxE2 e1 0 0) @ shift (length (compE2 e1)) (stack_xlift (length STK) (compxE2 e2 0 (Suc 0)))) @ (shift (length (compE2 e1 @ compE2 e2)) (compxE2 e3 0 (Suc (Suc (length STK)))))) t
     h (stk @ v1 # STK, loc, length (compE2 e1) + pc, a) ta h' (stk', loc', pc', xcp')"
    by(simp add: shift_compxE2 stack_xlift_compxE2 ac_simps)
  hence exec': "exec_meth_d (compP2 P) (compE2 e1 @ compE2 e2)
     (stack_xlift (length STK) (compxE2 e1 0 0) @ shift (length (compE2 e1)) (stack_xlift (length STK) (compxE2 e2 0 (Suc 0)))) t
     h (stk @ v1 # STK, loc, length (compE2 e1) + pc, a) ta h' (stk', loc', pc', xcp')"
    by(rule exec_meth_take_xt)(simp add: pc)
  hence "exec_meth_d (compP2 P) (compE2 e2) (stack_xlift (length STK) (compxE2 e2 0 (Suc 0))) t
     h (stk @ v1 # STK, loc, pc, a) ta h' (stk', loc', pc' - length (compE2 e1), xcp')"
    by(rule exec_meth_drop_xt)(auto simp add: stack_xlift_compxE2)
  hence "?exec e2 stk (v1 # STK) loc pc a stk' loc' (pc' - length (compE2 e1)) xcp'"
    by(simp add: compxE2_stack_xlift_convs)
  from IH2[OF this] obtain stk'' where stk': "stk' = stk'' @ v1 # STK" and
    exec'': "exec_meth_d (compP2 P) (compE2 e2) (compxE2 e2 0 0) t h (stk, loc, pc, a) ta h' (stk'', loc', pc' - length (compE2 e1), xcp')" by blast
  from exec'' have "exec_meth_d (compP2 P) (compE2 e2) (stack_xlift (length [v1]) (compxE2 e2 0 0)) t 
      h (stk @ [v1], loc, pc, a)
      ta h' (stk'' @ [v1], loc', pc' - length (compE2 e1), xcp')"
    by(rule exec_meth_stk_offer)
  hence "exec_meth_d (compP2 P) (compE2 e1 @ compE2 e2) (compxE2 e1 0 0 @ shift (length (compE2 e1)) (stack_xlift (length [v1]) (compxE2 e2 0 0))) t 
      h (stk @ [v1], loc, length (compE2 e1) + pc, a)
      ta h' (stk'' @ [v1], loc', length (compE2 e1) + (pc' - length (compE2 e1)), xcp')"
    by(rule append_exec_meth_xt)(auto)
  hence "exec_meth_d (compP2 P) ((compE2 e1 @ compE2 e2) @ compE2 e3 @ [CAS F D]) ((compxE2 e1 0 0 @ shift (length (compE2 e1)) (stack_xlift (length [v1]) (compxE2 e2 0 0))) @ (shift (length (compE2 e1 @ compE2 e2)) (compxE2 e3 0 (Suc (Suc 0))))) t
      h (stk @ [v1], loc, length (compE2 e1) + pc, a)
      ta h' (stk'' @ [v1], loc', length (compE2 e1) + (pc' - length (compE2 e1)), xcp')"
    by(rule exec_meth_append_xt)
  moreover from exec' have pc': "pc'  length (compE2 e1)"
    by(rule exec_meth_drop_xt_pc)(auto simp add: stack_xlift_compxE2)
  ultimately show ?case using stk' by(auto simp add: stack_xlift_compxE2 shift_compxE2)
next
  case (bisim1CASThrow3 e3 n a xs stk loc pc e1 e2 D F v2 v1)
  note bisim3 = P,e3,h  (Throw a, xs)  (stk, loc, pc, a)
  note IH3 = stk' loc' pc' xcp' STK. ?exec e3 stk STK loc pc a stk' loc' pc' xcp'
              ?concl e3 stk STK loc pc a stk' loc' pc' xcp'
  note exec = ?exec _ (stk @ [v2, v1]) STK loc (length (compE2 e1) + length (compE2 e2) + pc) a stk' loc' pc' xcp'
  from bisim3 have pc: "pc < length (compE2 e3)" and [simp]: "xs = loc"
    by(auto dest: bisim1_ThrowD)
  from exec have "exec_meth_d (compP2 P) (((compE2 e1 @ compE2 e2) @ compE2 e3) @ [CAS F D])
     ((stack_xlift (length STK) (compxE2 e1 0 0 @ compxE2 e2 (length (compE2 e1)) (Suc 0))) @ shift (length (compE2 e1 @ compE2 e2)) (stack_xlift (length (v2 # v1 # STK)) (compxE2 e3 0 0))) t
     h (stk @ v2 # v1 # STK, loc, length (compE2 e1 @ compE2 e2) + pc, a) ta h' (stk', loc', pc', xcp')"
    by(simp add: shift_compxE2 stack_xlift_compxE2 ac_simps)
  hence exec': "exec_meth_d (compP2 P) ((compE2 e1 @ compE2 e2) @ compE2 e3)
     ((stack_xlift (length STK) (compxE2 e1 0 0 @ compxE2 e2 (length (compE2 e1)) (Suc 0))) @ shift (length (compE2 e1 @ compE2 e2)) (stack_xlift (length (v2 # v1 # STK)) (compxE2 e3 0 0))) t
     h (stk @ v2 # v1 # STK, loc, length (compE2 e1 @ compE2 e2) + pc, a) ta h' (stk', loc', pc', xcp')"
    by(rule exec_meth_take)(simp add: pc)
  hence "?exec e3 stk (v2 # v1 # STK) loc pc a stk' loc' (pc' - length (compE2 e1 @ compE2 e2)) xcp'"
    by(rule exec_meth_drop_xt) auto
  from IH3[OF this] obtain stk'' where stk': "stk' = stk'' @ v2 # v1 # STK" and
    exec'': "exec_meth_d (compP2 P) (compE2 e3) (compxE2 e3 0 0) t h (stk, loc, pc, a) ta h' (stk'', loc', pc' - length (compE2 e1 @ compE2 e2), xcp')" by blast
  from exec'' have "exec_meth_d (compP2 P) (compE2 e3) (stack_xlift (length [v2, v1]) (compxE2 e3 0 0)) t h (stk @ [v2, v1], loc, pc, a)
      ta h' (stk'' @ [v2, v1], loc', pc' - length (compE2 e1 @ compE2 e2), xcp')"
    by(rule exec_meth_stk_offer)
  hence "exec_meth_d (compP2 P) ((compE2 e1 @ compE2 e2) @ compE2 e3) ((compxE2 e1 0 0 @ compxE2 e2 (length (compE2 e1)) (Suc 0)) @ shift (length (compE2 e1 @ compE2 e2)) (stack_xlift (length [v2, v1]) (compxE2 e3 0 0))) t h (stk @ [v2, v1], loc, length (compE2 e1 @ compE2 e2) + pc, a)
      ta h' (stk'' @ [v2, v1], loc', length (compE2 e1 @ compE2 e2) + (pc' - length (compE2 e1 @ compE2 e2)), xcp')"
    by(rule append_exec_meth_xt)(auto)
  hence "exec_meth_d (compP2 P) (((compE2 e1 @ compE2 e2) @ compE2 e3) @ [CAS F D]) ((compxE2 e1 0 0 @ compxE2 e2 (length (compE2 e1)) (Suc 0)) @ shift (length (compE2 e1 @ compE2 e2)) (stack_xlift (length [v2, v1]) (compxE2 e3 0 0))) t h (stk @ [v2, v1], loc, length (compE2 e1 @ compE2 e2) + pc, a)
      ta h' (stk'' @ [v2, v1], loc', length (compE2 e1 @ compE2 e2) + (pc' - length (compE2 e1 @ compE2 e2)), xcp')"
    by(rule exec_meth_append)
  moreover from exec' have pc': "pc'  length (compE2 e1 @ compE2 e2)"
    by(rule exec_meth_drop_xt_pc)(auto simp add: stack_xlift_compxE2)
  ultimately show ?case using stk' by(auto simp add: stack_xlift_compxE2 shift_compxE2)
next
  case bisim1CASFail thus ?case
    by(auto elim!: exec_meth.cases dest: match_ex_table_pcsD simp add: stack_xlift_compxEs2 stack_xlift_compxE2)
next
  case (bisim1Call1 obj n obj' xs stk loc pc xcp ps M')
  note bisimObj = P,obj,h  (obj', xs)  (stk, loc, pc, xcp)
  note IHobj = stk' loc' pc' xcp' STK. ?exec obj stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl obj stk STK loc pc xcp stk' loc' pc' xcp'
  note IHparams = xs stk' loc' pc' xcp' STK. ?execs ps [] STK xs 0 None stk' loc' pc' xcp'
              ?concls ps [] STK xs 0 None stk' loc' pc' xcp'
  note exec = ?exec (objM'(ps)) stk STK loc pc xcp stk' loc' pc' xcp'
  from bisimObj have pc: "pc  length (compE2 obj)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 obj)")
    case True
    from exec have "?exec obj stk STK loc pc xcp stk' loc' pc' xcp'"
      by(simp add: compxEs2_size_convs)(erule exec_meth_take_xt[OF _ True])
    from IHobj[OF this] show ?thesis by auto
  next
    case False
    with pc have [simp]: "pc = length (compE2 obj)" by simp
    with exec have "pc'  length (compE2 obj)"
      by(simp add: compxEs2_size_convs stack_xlift_compxE2)(auto elim!: exec_meth_drop_xt_pc)
    then obtain PC where PC: "pc' = PC + length (compE2 obj)"
      by -(rule_tac PC34="pc' - length (compE2 obj)" in that, simp)
    from pc bisimObj obtain v where [simp]: "stk = [v]" "xcp = None" by(auto dest: bisim1_pc_length_compE2D)
    show ?thesis
    proof(cases ps)
      case Cons
      with exec pc have "exec_meth_d (compP2 P) (compE2 obj @ compEs2 ps)
        (stack_xlift (length STK) (compxE2 obj 0 0 @ compxEs2 ps (length (compE2 obj)) (Suc 0))) t
        h (stk @ STK, loc, length (compE2 obj) + 0, xcp) ta h' (stk', loc', pc', xcp')"
        by -(rule exec_meth_take, auto)
      hence "?execs ps [] (v # STK) loc 0 None stk' loc' (pc' - length (compE2 obj)) xcp'"
        apply -
        apply(rule exec_meth_drop_xt)
        apply(simp add: compxEs2_size_convs compxEs2_stack_xlift_convs)
        apply(auto simp add: stack_xlift_compxE2)
        done
      from IHparams[OF this] PC obtain stk'' where stk': "stk' = stk'' @ v # STK"
        and exec': "exec_meth_d (compP2 P) (compEs2 ps) (compxEs2 ps 0 0) t h ([], loc, 0, None) ta h' (stk'', loc', PC, xcp')"
        by auto
      from exec' have "exec_meth_d (compP2 P) ((compE2 obj @ compEs2 ps) @ [Invoke M' (length ps)]) (compxE2 obj 0 0 @ shift (length (compE2 obj)) (stack_xlift (length [v]) (compxEs2 ps 0 0))) t h ([] @ [v], loc, length (compE2 obj) + 0, None) ta h' (stk'' @ [v], loc', length (compE2 obj) + PC, xcp')"
        apply -
        apply(rule exec_meth_append)
        apply(rule append_exec_meth_xt)
        apply(erule exec_meth_stk_offer)
        by(auto)
      thus ?thesis using stk' PC by(clarsimp simp add: shift_compxEs2 stack_xlift_compxEs2 ac_simps)
    next
      case Nil
      with exec pc show ?thesis 
        apply(auto elim!: exec_meth.cases intro!: exec_meth.intros simp add: split_beta split: if_split_asm)
        apply(auto split: extCallRet.split_asm intro!: exec_meth.intros)
        apply(force intro!: exI)
        apply(force intro!: exI)
        apply(force intro!: exI)
        done
    qed
  qed
next
  case (bisim1CallParams ps n ps' xs stk loc pc xcp obj M' v)
  note bisimParam = P,ps,h  (ps',xs) [↔] (stk,loc,pc,xcp)
  note IHparam = stk' loc' pc' xcp' STK. ?execs ps stk STK loc pc xcp stk' loc' pc' xcp'
              ?concls ps stk STK loc pc xcp stk' loc' pc' xcp'
  note exec = ?exec (objM'(ps)) (stk @ [v]) STK loc (length (compE2 obj) + pc) xcp stk' loc' pc' xcp'
  show ?case
  proof(cases ps)
    case Nil
    with bisimParam have "pc = 0" "xcp = None" by(auto elim: bisims1.cases)
    with exec Nil show ?thesis 
      apply(auto elim!: exec_meth.cases intro!: exec_meth.intros simp add: split_beta extRet2JVM_def split: if_split_asm)
      apply(auto split: extCallRet.split_asm simp add: neq_Nil_conv)
      apply(force intro!: exec_meth.intros)+
      done
  next
    case Cons
    from bisimParam have pc: "pc  length (compEs2 ps)" by(rule bisims1_pc_length_compEs2)
    show ?thesis
    proof(cases "pc < length (compEs2 ps)")
      case True
      from exec have "exec_meth_d (compP2 P) ((compE2 obj @ compEs2 ps) @ [Invoke M' (length ps)])
        (stack_xlift (length STK) (compxE2 obj 0 0) @ shift (length (compE2 obj)) (stack_xlift (length (v # STK)) (compxEs2 ps 0 0))) t
        h (stk @ v # STK, loc, length (compE2 obj) + pc, xcp) ta h' (stk', loc', pc', xcp')"
        by(simp add: compxEs2_size_convs compxEs2_stack_xlift_convs)
      hence exec': "exec_meth_d (compP2 P) (compE2 obj @ compEs2 ps) (stack_xlift (length STK) (compxE2 obj 0 0) @
        shift (length (compE2 obj)) (stack_xlift (length (v # STK)) (compxEs2 ps 0 0))) t
        h (stk @ v # STK, loc, length (compE2 obj) + pc, xcp) ta h' (stk', loc', pc', xcp')"
        by(rule exec_meth_take)(simp add: True)
      hence "?execs ps stk (v # STK) loc pc xcp stk' loc' (pc' - length (compE2 obj)) xcp'"
        by(rule exec_meth_drop_xt)(auto simp add: stack_xlift_compxE2)
      from IHparam[OF this] obtain stk'' where stk': "stk' = stk'' @ v # STK"
        and exec'': "exec_meth_d (compP2 P) (compEs2 ps) (compxEs2 ps 0 0) t h (stk, loc, pc, xcp) ta h' (stk'', loc', pc' - length (compE2 obj), xcp')" by blast
      from exec'' have "exec_meth_d (compP2 P) (compEs2 ps) (stack_xlift (length [v]) (compxEs2 ps 0 0)) t h (stk @ [v], loc, pc, xcp) ta h' (stk'' @ [v], loc', pc' - length (compE2 obj), xcp')"
        by(rule exec_meth_stk_offer)
      hence "exec_meth_d (compP2 P) (compE2 obj @ compEs2 ps) (compxE2 obj 0 0 @ shift (length (compE2 obj)) (stack_xlift (length [v]) (compxEs2 ps 0 0))) t
 h (stk @ [v], loc, length (compE2 obj) + pc, xcp) ta h' (stk'' @ [v], loc', length (compE2 obj) + (pc' - length (compE2 obj)), xcp')"
        by(rule append_exec_meth_xt) auto
      hence "exec_meth_d (compP2 P) ((compE2 obj @ compEs2 ps) @ [Invoke M' (length ps)])
     (compxE2 obj 0 0 @ shift (length (compE2 obj)) (stack_xlift (length [v]) (compxEs2 ps 0 0))) t
 h (stk @ [v], loc, length (compE2 obj) + pc, xcp) ta h' (stk'' @ [v], loc', length (compE2 obj) + (pc' - length (compE2 obj)), xcp')"
        by(rule exec_meth_append)
      moreover from exec' have "pc'  length (compE2 obj)"
        by(rule exec_meth_drop_xt_pc)(auto simp add: stack_xlift_compxE2)
      ultimately show ?thesis using stk'
        by(auto simp add: shift_compxEs2 stack_xlift_compxEs2)
    next
      case False
      with pc have pc: "pc = length (compEs2 ps)" by simp
      with bisimParam obtain vs where "stk = vs" "length vs = length ps" "xcp = None"
        by(auto dest: bisims1_pc_length_compEs2D)
      with exec pc Cons show ?thesis
        apply(auto elim!: exec_meth.cases intro!: exec_meth.intros simp add: split_beta extRet2JVM_def split: if_split_asm)
        apply(auto simp add: neq_Nil_conv split: extCallRet.split_asm)
        apply(force intro!: exec_meth.intros)+
        done
    qed
  qed
next
  case (bisim1CallThrowObj obj n a xs stk loc pc ps M')
  note bisim = P,obj,h  (Throw a, xs)  (stk, loc, pc, a)
  note IH = stk' loc' pc' xcp' STK. ?exec obj stk STK loc pc a stk' loc' pc' xcp'
              ?concl obj stk STK loc pc a stk' loc' pc' xcp'
  note exec = ?exec (objM'(ps)) stk STK loc pc a stk' loc' pc' xcp'
  from bisim have "pc < length (compE2 obj)" and [simp]: "xs = loc" by(auto dest: bisim1_ThrowD)
  with exec have "?exec obj stk STK loc pc a stk' loc' pc' xcp'"
    by(simp add: compxEs2_size_convs compxEs2_stack_xlift_convs)(erule exec_meth_take_xt)
  from IH[OF this] show ?case by auto
next
  case (bisim1CallThrowParams ps n vs a ps' xs stk loc pc obj M' v)
  note bisim = P,ps,h  (map Val vs @ Throw a # ps',xs) [↔] (stk,loc,pc,a)
  note IH = stk' loc' pc' xcp' STK. ?execs ps stk STK loc pc a stk' loc' pc' xcp'
              ?concls ps stk STK loc pc a stk' loc' pc' xcp'
  note exec = ?exec (objM'(ps)) (stk @ [v]) STK loc (length (compE2 obj) + pc) a stk' loc' pc' xcp'
  from bisim have pc: "pc < length (compEs2 ps)" "loc = xs" by(auto dest: bisims1_ThrowD)
  from exec have "exec_meth_d (compP2 P) ((compE2 obj @ compEs2 ps) @ [Invoke M' (length ps)])
     (stack_xlift (length STK) (compxE2 obj 0 0) @ shift (length (compE2 obj)) (stack_xlift (length (v # STK)) (compxEs2 ps 0 0))) t
     h (stk @ v # STK, loc, length (compE2 obj) + pc, a) ta h' (stk', loc', pc', xcp')"
    by(simp add: compxEs2_size_convs compxEs2_stack_xlift_convs)
  hence exec': "exec_meth_d (compP2 P) (compE2 obj @ compEs2 ps) (stack_xlift (length STK) (compxE2 obj 0 0) @
      shift (length (compE2 obj)) (stack_xlift (length (v # STK)) (compxEs2 ps 0 0))) t
     h (stk @ v # STK, loc, length (compE2 obj) + pc, a) ta h' (stk', loc', pc', xcp')"
    by(rule exec_meth_take)(simp add: pc)
  hence "?execs ps stk (v # STK) loc pc a stk' loc' (pc' - length (compE2 obj)) xcp'"
    by(rule exec_meth_drop_xt)(auto simp add: stack_xlift_compxE2)
  from IH[OF this] obtain stk'' where stk': "stk' = stk'' @ v # STK"
    and exec'': "exec_meth_d (compP2 P) (compEs2 ps) (compxEs2 ps 0 0) t h (stk, loc, pc, a) ta h' (stk'', loc', pc' - length (compE2 obj), xcp')" by auto
  from exec'' have "exec_meth_d (compP2 P) ((compE2 obj @ compEs2 ps) @ [Invoke M' (length ps)])
     (compxE2 obj 0 0 @ shift (length (compE2 obj)) (stack_xlift (length [v]) (compxEs2 ps 0 0))) t
     h (stk @ [v], loc, length (compE2 obj) + pc, a) ta h' (stk'' @ [v], loc', length (compE2 obj) + (pc' - length (compE2 obj)), xcp')"
    apply - 
    apply(rule exec_meth_append)
    apply(rule append_exec_meth_xt)
    apply(erule exec_meth_stk_offer)
    apply auto
    done
  moreover from exec' have "pc'  length (compE2 obj)"
    by(rule exec_meth_drop_xt_pc)(auto simp add: stack_xlift_compxE2)
  ultimately show ?case using stk' by(auto simp add: compxEs2_size_convs compxEs2_stack_xlift_convs)
next
  case bisim1CallThrow thus ?case
    by(auto elim!: exec_meth.cases dest: match_ex_table_pcsD simp add: stack_xlift_compxEs2 stack_xlift_compxE2)
next
  case bisim1BlockSome1 thus ?case
    by(fastforce elim: exec_meth.cases intro: exec_meth.intros)
next
  case bisim1BlockSome2 thus ?case
    by(fastforce elim: exec_meth.cases intro: exec_meth.intros)
next
  case (bisim1BlockSome4 e n e' xs stk loc pc xcp V T v)
  note IH = stk' loc' pc' xcp' STK. ?exec e stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl e stk STK loc pc xcp stk' loc' pc' xcp'
  note bisim = P,e,h  (e', xs)  (stk, loc, pc, xcp)
  note exec = ?exec {V:T=v; e} stk STK loc (Suc (Suc pc)) xcp stk' loc' pc' xcp'
  hence exec': "exec_meth_d (compP2 P) ([Push v, Store V] @ compE2 e)
     (shift (length [Push v, Store V]) (stack_xlift (length STK) (compxE2 e 0 0))) t h (stk @ STK, loc, length [Push v, Store V] + pc, xcp) ta h' (stk', loc', pc', xcp')"
    by(simp add: compxE2_size_convs)
  hence "?exec e stk STK loc pc xcp stk' loc' (pc' - length [Push v, Store V]) xcp'"
    by(rule exec_meth_drop) auto
  from IH[OF this] obtain stk'' where stk': "stk' = stk'' @ STK"
    and exec'': "exec_meth_d (compP2 P) (compE2 e) (compxE2 e 0 0) t h (stk, loc, pc, xcp) ta
      h' (stk'', loc', pc' - length [Push v, Store V], xcp')" by auto
  from exec'' have "exec_meth_d (compP2 P) ([Push v, Store V] @ compE2 e)
     (shift (length [Push v, Store V]) (compxE2 e 0 0)) t h (stk, loc, length [Push v, Store V] + pc, xcp) ta h' (stk'', loc', length [Push v, Store V] + (pc' - length [Push v, Store V]), xcp')"
    by(rule append_exec_meth) auto
  moreover from exec' have "pc'  length [Push v, Store V]"
    by(rule exec_meth_drop_pc)(auto simp add: stack_xlift_compxE2)
  hence "Suc (Suc (pc' - Suc (Suc 0))) = pc'" by(simp)
  ultimately show ?case using stk' by(auto simp add: compxE2_size_convs)
next
  case (bisim1BlockThrowSome e n a xs stk loc pc V T v)
  note IH = stk' loc' pc' xcp' STK. ?exec e stk STK loc pc a stk' loc' pc' xcp'
              ?concl e stk STK loc pc a stk' loc' pc' xcp'
  note exec = ?exec {V:T=v; e} stk STK loc (Suc (Suc pc)) a stk' loc' pc' xcp'
  hence exec': "exec_meth_d (compP2 P) ([Push v, Store V] @ compE2 e)
     (shift (length [Push v, Store V]) (stack_xlift (length STK) (compxE2 e 0 0))) t h (stk @ STK, loc, length [Push v, Store V] + pc, a) ta h' (stk', loc', pc', xcp')"
    by(simp add: compxE2_size_convs)
  hence "?exec e stk STK loc pc a stk' loc' (pc' - length [Push v, Store V]) xcp'"
    by(rule exec_meth_drop) auto
  from IH[OF this] obtain stk'' where stk': "stk' = stk'' @ STK"
    and exec'': "exec_meth_d (compP2 P) (compE2 e) (compxE2 e 0 0) t h (stk, loc, pc, a) ta
      h' (stk'', loc', pc' - length [Push v, Store V], xcp')" by auto
  from exec'' have "exec_meth_d (compP2 P) ([Push v, Store V] @ compE2 e)
     (shift (length [Push v, Store V]) (compxE2 e 0 0)) t h (stk, loc, length [Push v, Store V] + pc, a) ta h' (stk'', loc', length [Push v, Store V] + (pc' - length [Push v, Store V]), xcp')"
    by(rule append_exec_meth) auto
  moreover from exec' have "pc'  length [Push v, Store V]"
    by(rule exec_meth_drop_pc)(auto simp add: stack_xlift_compxE2)
  hence "Suc (Suc (pc' - Suc (Suc 0))) = pc'" by(simp)
  ultimately show ?case using stk' by(auto simp add: compxE2_size_convs)
next
  case bisim1BlockNone thus ?case
    by(fastforce elim: exec_meth.cases intro: exec_meth.intros)
next
  case bisim1BlockThrowNone thus ?case
    by(fastforce elim: exec_meth.cases intro: exec_meth.intros)
next
  case (bisim1Sync1 e1 n e1' xs stk loc pc xcp e2 V)
  note bisim = P,e1,h  (e1', xs)  (stk, loc, pc, xcp)
  note IH = stk' loc' pc' xcp' STK. ?exec e1 stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl e1 stk STK loc pc xcp stk' loc' pc' xcp'
  note exec = ?exec (syncV (e1) e2) stk STK loc pc xcp stk' loc' pc' xcp'
  from bisim have pc: "pc  length (compE2 e1)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e1)")
    case True
    from exec have "exec_meth_d (compP2 P)
      (compE2 e1 @ (Dup # Store V # MEnter # compE2 e2 @ [Load V, MExit, Goto 4, Load V, MExit, ThrowExc]))
      (stack_xlift (length STK) (compxE2 e1 0 0) @ shift (length (compE2 e1)) (stack_xlift (length STK) (compxE2 e2 3 0) @
       stack_xlift (length STK) [(3, 3 + length (compE2 e2), None, 6 + length (compE2 e2), 0)])) t
      h (stk @ STK, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
      by(simp add: shift_compxE2 stack_xlift_compxE2 ac_simps)
    hence "?exec e1 stk STK loc pc xcp stk' loc' pc' xcp'"
      by(rule exec_meth_take_xt)(rule True)
    from IH[OF this] obtain stk'' where stk': "stk' = stk'' @ STK"
      and exec': "exec_meth_d (compP2 P) (compE2 e1) (compxE2 e1 0 0) t h (stk, loc, pc, xcp) ta h' (stk'', loc', pc', xcp')"
      by blast
    from exec' have "exec_meth_d (compP2 P) (compE2 e1 @ (Dup # Store V # MEnter # compE2 e2 @ [Load V, MExit, Goto 4, Load V, MExit, ThrowExc]))
      (compxE2 e1 0 0 @ shift (length (compE2 e1)) (compxE2 e2 3 0 @ [(3, 3 + length (compE2 e2), None, 6 + length (compE2 e2), 0)])) t
      h (stk, loc, pc, xcp) ta h' (stk'', loc', pc', xcp')"
      by(rule exec_meth_append_xt)
    thus ?thesis using stk' by(simp add: shift_compxE2 stack_xlift_compxE2 ac_simps)
  next
    case False
    with pc have [simp]: "pc = length (compE2 e1)" by simp
    with bisim obtain v where "stk = [v]" "xcp = None" by(auto dest: bisim1_pc_length_compE2D)
    thus ?thesis using exec by(auto elim!: exec_meth.cases intro!: exec_meth.intros)
  qed
next
  case bisim1Sync2 thus ?case
    by(fastforce elim!: exec_meth.cases intro!: exec_meth.intros)
next
  case bisim1Sync3 thus ?case
    by(fastforce elim!: exec_meth.cases intro!: exec_meth.intros split: if_split_asm)
next
  case (bisim1Sync4 e2 n e2' xs stk loc pc xcp e1 V a)
  note IH = stk' loc' pc' xcp' STK. ?exec e2 stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl e2 stk STK loc pc xcp stk' loc' pc' xcp'
  note bisim = P,e2,h  (e2', xs)  (stk, loc, pc, xcp)
  note exec = ?exec (syncV (e1) e2) stk STK loc (Suc (Suc (Suc (length (compE2 e1) + pc)))) xcp stk' loc' pc' xcp'
  from bisim have pc: "pc  length (compE2 e2)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e2)")
    case True
    let ?pre = "compE2 e1 @ [Dup, Store V, MEnter]"
    from exec have exec': "exec_meth_d (compP2 P) (?pre @ compE2 e2 @ [Load V, MExit, Goto 4, Load V, MExit, ThrowExc])
     (stack_xlift (length STK) (compxE2 e1 0 0) @ shift (length ?pre) (stack_xlift (length STK) (compxE2 e2 0 0) @
      [(0, length (compE2 e2), None, 3 + length (compE2 e2), length STK)])) t
     h (stk @ STK, loc, length ?pre + pc, xcp) ta h' (stk', loc', pc', xcp')"
      by(simp add: stack_xlift_compxE2 shift_compxE2 eval_nat_numeral ac_simps)
    hence exec'': "exec_meth_d (compP2 P) (compE2 e2 @ [Load V, MExit, Goto 4, Load V, MExit, ThrowExc])
      (stack_xlift (length STK) (compxE2 e2 0 0) @ [(0, length (compE2 e2), None, 3 + length (compE2 e2), length STK)]) t
     h (stk @ STK, loc, pc, xcp) ta h' (stk', loc', pc' - length ?pre, xcp')"
      by(rule exec_meth_drop_xt[where n=1])(auto simp add: stack_xlift_compxE2)
    from exec' have pc': "pc'  length ?pre"
      by(rule exec_meth_drop_xt_pc[where n'=1])(auto simp add: stack_xlift_compxE2)
    hence pc'': "(Suc (Suc (Suc (pc' - Suc (Suc (Suc 0)))))) = pc'" by simp
    show ?thesis
    proof(cases xcp)
      case None
      from exec'' None True
      have "?exec e2 stk STK loc pc xcp stk' loc' (pc' - length ?pre) xcp'"
        apply -
        apply (erule exec_meth.cases)
        apply (cases "compE2 e2 ! pc")
                            apply (fastforce simp add: is_Ref_def intro: exec_meth.intros split: if_split_asm cong del: image_cong_simp)+
        done
      from IH[OF this] obtain stk'' where stk: "stk' = stk'' @ STK"
        and exec''': "exec_meth_d (compP2 P) (compE2 e2) (compxE2 e2 0 0) t h (stk, loc, pc, xcp)
      ta h' (stk'', loc', pc' - length ?pre, xcp')" by blast
      from exec''' have "exec_meth_d (compP2 P) (compE2 e2 @ [Load V, MExit, Goto 4, Load V, MExit, ThrowExc])
      (compxE2 e2 0 0 @ [(0, length (compE2 e2), None, 3 + length (compE2 e2), 0)]) t
     h (stk, loc, pc, xcp) ta h' (stk'', loc', pc' - length ?pre, xcp')"
        by(rule exec_meth_append_xt)
      hence "exec_meth_d (compP2 P) (?pre @ compE2 e2 @ [Load V, MExit, Goto 4, Load V, MExit, ThrowExc])
      (compxE2 e1 0 0 @ shift (length ?pre) (compxE2 e2 0 0 @ [(0, length (compE2 e2), None, 3 + length (compE2 e2), 0)])) t
     h (stk, loc, length ?pre + pc, xcp) ta h' (stk'', loc', length ?pre + (pc' - length ?pre), xcp')"
        by(rule append_exec_meth_xt[where n=1]) auto
      thus ?thesis using stk pc' pc'' by(simp add: eval_nat_numeral shift_compxE2 ac_simps)
    next
      case (Some a)
      with exec'' have [simp]: "h' = h" "xcp' = None" "loc' = loc" "ta = ε"
        by(auto elim!: exec_meth.cases simp add: match_ex_table_append
           split: if_split_asm dest!: match_ex_table_stack_xliftD)
      show ?thesis
      proof(cases "match_ex_table (compP2 P) (cname_of h a) pc (compxE2 e2 0 0)")
        case None
        with Some exec'' True have [simp]: "stk' = Addr a # STK"
          and pc': "pc' = length (compE2 e1) + length (compE2 e2) + 6"
          by(auto elim!: exec_meth.cases simp add: match_ex_table_append
                  split: if_split_asm dest!: match_ex_table_stack_xliftD)
        with exec'' Some None
        have "exec_meth_d (compP2 P) (compE2 e2 @ [Load V, MExit, Goto 4, Load V, MExit, ThrowExc])
        (compxE2 e2 0 0 @ [(0, length (compE2 e2), None, 3 + length (compE2 e2), 0)]) t
        h (stk, loc, pc, a) ε h (Addr a # drop (length stk - 0) stk, loc, pc' - length ?pre, None)"
          by -(rule exec_catch, auto elim!: exec_meth.cases simp add: match_ex_table_append matches_ex_entry_def
                                     split: if_split_asm dest!: match_ex_table_stack_xliftD)
        hence "exec_meth_d (compP2 P) (?pre @ compE2 e2 @ [Load V, MExit, Goto 4, Load V, MExit, ThrowExc])
        (compxE2 e1 0 0 @ shift (length ?pre) (compxE2 e2 0 0 @ [(0, length (compE2 e2), None, 3 + length (compE2 e2), 0)])) t
        h (stk, loc, length ?pre + pc, a) ε h (Addr a # drop (length stk - 0) stk, loc,
        length ?pre + (pc' - length ?pre), None)"
          by(rule append_exec_meth_xt[where n=1]) auto
        with pc' Some show ?thesis by(simp add: eval_nat_numeral shift_compxE2 ac_simps)
      next
        case (Some pcd)
        with xcp = a exec'' True
        have "exec_meth_d (compP2 P) (compE2 e2) (compxE2 e2 0 0) t
          h (stk, loc, pc, a) ε h (Addr a # drop (length stk - snd pcd) stk, loc, pc' - length ?pre, None)"
          apply -
          apply(rule exec_catch)
          apply(auto elim!: exec_meth.cases simp add: match_ex_table_append split: if_split_asm
                     dest!: match_ex_table_stack_xliftD)
          done
        hence "exec_meth_d (compP2 P) (compE2 e2 @ [Load V, MExit, Goto 4, Load V, MExit, ThrowExc]) (compxE2 e2 0 0 @ [(0, length (compE2 e2), None, 3 + length (compE2 e2), 0)]) t
   h (stk, loc, pc, a) ε h (Addr a # drop (length stk - snd pcd) stk, loc, pc' - length ?pre, None)"
          by(rule exec_meth_append_xt)
        hence "exec_meth_d (compP2 P) (?pre @ compE2 e2 @ [Load V, MExit, Goto 4, Load V, MExit, ThrowExc]) 
              (compxE2 e1 0 0 @ shift (length ?pre) (compxE2 e2 0 0 @ [(0, length (compE2 e2), None, 3 + length (compE2 e2), 0)])) t
   h (stk, loc, length ?pre + pc, a) ε h (Addr a # drop (length stk - snd pcd) stk, loc, length ?pre + (pc' - length ?pre), None)"
          by(rule append_exec_meth_xt[where n=1])(auto)
        moreover from Some xcp = a exec'' True pc'
        have "pc' = length (compE2 e1) + 3 + fst pcd" "stk' = Addr a # drop (length stk - snd pcd) stk @ STK"
          by(auto elim!: exec_meth.cases dest!: match_ex_table_stack_xliftD simp: match_ex_table_append split: if_split_asm)
        ultimately show ?thesis using xcp = a by(auto simp add: eval_nat_numeral shift_compxE2 ac_simps)
      qed
    qed
  next
    case False
    with pc have [simp]: "pc = length (compE2 e2)" by simp
    with exec show ?thesis
      by(auto elim!: exec_meth.cases intro!: exec_meth.intros split: if_split_asm simp add: match_ex_table_append_not_pcs eval_nat_numeral)(simp_all add: matches_ex_entry_def)
  qed
next
  case bisim1Sync5 thus ?case
    by(fastforce elim: exec_meth.cases intro: exec_meth.intros split: if_split_asm)
next
  case bisim1Sync6 thus ?case  
    by(fastforce elim: exec_meth.cases intro: exec_meth.intros split: if_split_asm)     
next
  case bisim1Sync7 thus ?case
    by(fastforce elim: exec_meth.cases intro: exec_meth.intros split: if_split_asm)
next
  case bisim1Sync8 thus ?case
    by(fastforce elim: exec_meth.cases intro: exec_meth.intros split: if_split_asm)
next
  case (bisim1Sync9 e1 n e2 V a xs)
  note exec = ?exec (syncV (e1) e2) [Addr a] STK xs (8 + length (compE2 e1) + length (compE2 e2)) None stk' loc' pc' xcp'
  let ?pre = "compE2 e1 @ Dup # Store V # MEnter # compE2 e2 @ [Load V, MExit, Goto 4, Load V, MExit]"
  from exec have exec': "exec_meth_d (compP2 P) (?pre @ [ThrowExc]) (stack_xlift (length STK) (compxE2 (syncV (e1) e2) 0 0) @ shift (length ?pre) []) t h (Addr a # STK, xs, length ?pre + 0, None) ta h' (stk', loc', pc', xcp')"
    by(simp add: eval_nat_numeral)
  hence "exec_meth_d (compP2 P) [ThrowExc] [] t h (Addr a # STK, xs, 0, None) ta h' (stk', loc', pc' - length ?pre, xcp')"
    by(rule exec_meth_drop_xt)(auto simp add: stack_xlift_compxE2)
  moreover from exec' have "pc' = 8 + length (compE2 e1) + length (compE2 e2)" "stk' = Addr a # STK"
    by(auto elim!: exec_meth.cases)
  ultimately show ?case by(fastforce elim!: exec_meth.cases intro: exec_meth.intros)
next
  case (bisim1Sync10 e1 n e2 V a xs)
  note exec = ?exec (syncV (e1) e2) [Addr a] STK xs (8 + length (compE2 e1) + length (compE2 e2)) a stk' loc' pc' xcp'
  hence "match_ex_table (compP2 P) (cname_of h a) (8 + length (compE2 e1) + length (compE2 e2)) (stack_xlift (length STK) (compxE2 (syncV (e1) e2) 0 0))  None"
    by(rule exec_meth.cases) auto
  hence False by(auto split: if_split_asm simp add: match_ex_table_append_not_pcs)(simp add: matches_ex_entry_def)
  thus ?case ..
next
  case (bisim1Sync11 e1 n e2 V xs)
  note exec = ?exec (syncV (e1) e2) [Null] STK xs (Suc (Suc (length (compE2 e1)))) addr_of_sys_xcpt NullPointer stk' loc' pc' xcp'
  hence "match_ex_table (compP2 P) (cname_of h (addr_of_sys_xcpt NullPointer)) (2 + length (compE2 e1)) (stack_xlift (length STK) (compxE2 (syncV (e1) e2) 0 0))  None"
    by(rule exec_meth.cases)(auto split: if_split_asm)
  hence False by(auto split: if_split_asm simp add: match_ex_table_append_not_pcs)(simp add: matches_ex_entry_def)
  thus ?case ..
next
  case (bisim1SyncThrow e1 n a xs stk loc pc e2 V)
  note exec = ?exec (syncV (e1) e2) stk STK loc pc a stk' loc' pc' xcp'
  note IH = stk' loc' pc' xcp' STK. ?exec e1 stk STK loc pc a stk' loc' pc' xcp'
              ?concl e1 stk STK loc pc a stk' loc' pc' xcp'
  note bisim = P,e1,h  (Throw a, xs)  (stk, loc, pc, a)
  from bisim have pc: "pc < length (compE2 e1)"
    and [simp]: "loc = xs" by(auto dest: bisim1_ThrowD)
  from exec have "exec_meth_d (compP2 P) (compE2 e1 @ Dup # Store V # MEnter # compE2 e2 @ [Load V, MExit, Goto 4, Load V, MExit, ThrowExc])
     (stack_xlift (length STK) (compxE2 e1 0 0) @ shift (length (compE2 e1)) (stack_xlift (length STK) (compxE2 e2 3 0) @
      [(3, 3 + length (compE2 e2), None, 6 + length (compE2 e2), length STK)])) t
     h (stk @ STK, loc, pc, a) ta h' (stk', loc', pc', xcp')"
    by(simp add: shift_compxE2 stack_xlift_compxE2 ac_simps)
  hence "?exec e1 stk STK loc pc a stk' loc' pc' xcp'"
    by(rule exec_meth_take_xt)(rule pc)
  from IH[OF this] show ?case by auto
next
  case (bisim1Seq1 e1 n e1' xs stk loc pc xcp e2)
  note bisim1 = P,e1,h  (e1', xs)  (stk, loc, pc, xcp)
  note IH = stk' loc' pc' xcp' STK. ?exec e1 stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl e1 stk STK loc pc xcp stk' loc' pc' xcp'
  note exec = ?exec (e1;;e2) stk STK loc pc xcp stk' loc' pc' xcp'
  from bisim1 have pc: "pc  length (compE2 e1)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e1)")
    case True
    from exec have "exec_meth_d (compP2 P) (compE2 e1 @ Pop # compE2 e2) (stack_xlift (length STK) (compxE2 e1 0 0) @
      shift (length (compE2 e1)) (stack_xlift (length STK) (compxE2 e2 (Suc 0) 0))) t
     h (stk @ STK, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
      by(simp add: shift_compxE2 stack_xlift_compxE2)
    hence "?exec e1 stk STK loc pc xcp stk' loc' pc' xcp'"
      by(rule exec_meth_take_xt)(rule True)
    from IH[OF this] show ?thesis by auto
  next
    case False
    with pc have [simp]: "pc = length (compE2 e1)" by simp
    with bisim1 obtain v where "xcp = None" "stk = [v]" by(auto dest: bisim1_pc_length_compE2D)
    with exec show ?thesis by(fastforce elim: exec_meth.cases intro: exec_meth.intros)
  qed
next
  case (bisim1SeqThrow1 e1 n a xs stk loc pc e2)
  note bisim1 = P,e1,h  (Throw a, xs)  (stk, loc, pc, a)
  note IH = stk' loc' pc' xcp' STK. ?exec e1 stk STK loc pc a stk' loc' pc' xcp'
              ?concl e1 stk STK loc pc a stk' loc' pc' xcp'
  note exec = ?exec (e1;;e2) stk STK loc pc a stk' loc' pc' xcp'
  from bisim1 have pc: "pc < length (compE2 e1)" by(auto dest: bisim1_ThrowD)
  from exec have "exec_meth_d (compP2 P) (compE2 e1 @ Pop # compE2 e2) (stack_xlift (length STK) (compxE2 e1 0 0) @
      shift (length (compE2 e1)) (stack_xlift (length STK) (compxE2 e2 (Suc 0) 0))) t
     h (stk @ STK, loc, pc, a) ta h' (stk', loc', pc', xcp')"
    by(simp add: shift_compxE2 stack_xlift_compxE2)
  hence "?exec e1 stk STK loc pc a stk' loc' pc' xcp'"
    by(rule exec_meth_take_xt)(rule pc)
  from IH[OF this] show ?case by(fastforce elim: exec_meth.cases intro: exec_meth.intros)
next
  case (bisim1Seq2 e2 n e2' xs stk loc pc xcp e1)
  note bisim2 = P,e2,h  (e2', xs)  (stk, loc, pc, xcp)
  note IH = stk' loc' pc' xcp' STK. ?exec e2 stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl e2 stk STK loc pc xcp stk' loc' pc' xcp'
  note exec = ?exec (e1;;e2) stk STK loc (Suc (length (compE2 e1) + pc)) xcp stk' loc' pc' xcp'
  from bisim2 have pc: "pc  length (compE2 e2)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e2)")
    case False
    with pc have [simp]: "pc = length (compE2 e2)" by simp
    from bisim2 have "xcp = None" by(auto dest: bisim1_pc_length_compE2D)
    with exec have False by(auto elim: exec_meth.cases)
    thus ?thesis ..
  next
    case True
    from exec have exec':
      "exec_meth_d (compP2 P) ((compE2 e1 @ [Pop]) @ compE2 e2) (stack_xlift (length STK) (compxE2 e1 0 0) @
      shift (length (compE2 e1 @ [Pop])) (stack_xlift (length STK) (compxE2 e2 0 0))) t
     h (stk @ STK, loc, length ((compE2 e1) @ [Pop]) + pc, xcp) ta h' (stk', loc', pc', xcp')"
      by(simp add: compxE2_size_convs)
    hence "?exec e2 stk STK loc pc xcp stk' loc' (pc' - length ((compE2 e1) @ [Pop])) xcp'"
      by(rule exec_meth_drop_xt)(auto simp add: stack_xlift_compxE2)
    from IH[OF this] obtain stk'' where stk': "stk' = stk'' @ STK"
      and exec'': "exec_meth_d (compP2 P) (compE2 e2) (compxE2 e2 0 0) t h (stk, loc, pc, xcp)
      ta h' (stk'', loc', pc' - length (compE2 e1 @ [Pop]), xcp')" by auto
    from exec'' have "exec_meth_d (compP2 P) ((compE2 e1 @ [Pop]) @ compE2 e2) (compxE2 e1 0 0 @ shift (length (compE2 e1 @ [Pop])) (compxE2 e2 0 0)) t
     h (stk, loc, length ((compE2 e1) @ [Pop]) + pc, xcp) ta h' (stk'', loc', length ((compE2 e1) @ [Pop]) + (pc' - length ((compE2 e1) @ [Pop])), xcp')"
      by(rule append_exec_meth_xt) auto
    moreover from exec' have "pc'  length ((compE2 e1) @ [Pop])"
      by(rule exec_meth_drop_xt_pc)(auto simp add: stack_xlift_compxE2)
    ultimately show ?thesis using stk' by(auto simp add: shift_compxE2 stack_xlift_compxE2)
  qed
next
  case (bisim1Cond1 e n e' xs stk loc pc xcp e1 e2)
  note bisim = P,e,h  (e', xs)  (stk, loc, pc, xcp)
  note IH = stk' loc' pc' xcp' STK. ?exec e stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl e stk STK loc pc xcp stk' loc' pc' xcp'
  note exec = ?exec (if (e) e1 else e2) stk STK loc pc xcp stk' loc' pc' xcp'
  from bisim have pc: "pc  length (compE2 e)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e)")
    case True
    from exec have "exec_meth_d (compP2 P) (compE2 e @ IfFalse (2 + int (length (compE2 e1))) # compE2 e1 @ Goto (1 + int (length (compE2 e2))) # compE2 e2)
     (stack_xlift (length STK) (compxE2 e 0 0) @ shift (length (compE2 e)) (stack_xlift (length STK) (compxE2 e1 (Suc 0) 0) @
      stack_xlift (length STK) (compxE2 e2 (Suc (Suc (length (compE2 e1)))) 0))) t
     h (stk @ STK, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
      by(simp add: stack_xlift_compxE2 shift_compxE2 ac_simps)
    hence "?exec e stk STK loc pc xcp stk' loc' pc' xcp'"
      by(rule exec_meth_take_xt)(rule True)
    from IH[OF this] show ?thesis by auto
  next
    case False
    with pc have [simp]: "pc = length (compE2 e)" by simp
    from bisim obtain v where "stk = [v]" "xcp = None"
      by(auto dest: bisim1_pc_length_compE2D)
    with exec show ?thesis by(auto elim!: exec_meth.cases intro!: exec_meth.intros)
  qed
next
  case (bisim1CondThen e1 n e1' xs stk loc pc xcp e e2)
  note bisim = P,e1,h  (e1', xs)  (stk, loc, pc, xcp)
  note IH = stk' loc' pc' xcp' STK. ?exec e1 stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl e1 stk STK loc pc xcp stk' loc' pc' xcp'
  note exec = ?exec (if (e) e1 else e2) stk STK loc (Suc (length (compE2 e) + pc)) xcp stk' loc' pc' xcp'
  from bisim have pc: "pc  length (compE2 e1)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e1)")
    case True
    let ?pre = "compE2 e @ [IfFalse (2 + int (length (compE2 e1)))]"
    from exec have exec': "exec_meth_d (compP2 P) (?pre @ compE2 e1 @ Goto (1 + int (length (compE2 e2))) # compE2 e2)
     (stack_xlift (length STK) (compxE2 e 0 0) @ shift (length ?pre) (stack_xlift (length STK) (compxE2 e1 0 0) @
      shift (length (compE2 e1)) (stack_xlift (length STK) (compxE2 e2 (Suc 0) 0)))) t
     h (stk @ STK, loc, length ?pre + pc, xcp) ta h' (stk', loc', pc', xcp')"
      by(simp add: stack_xlift_compxE2 shift_compxE2 ac_simps)
    hence "exec_meth_d (compP2 P) (compE2 e1 @ Goto (1 + int (length (compE2 e2))) # compE2 e2)
      (stack_xlift (length STK) (compxE2 e1 0 0) @ shift (length (compE2 e1)) (stack_xlift (length STK) (compxE2 e2 (Suc 0) 0))) t
     h (stk @ STK, loc, pc, xcp) ta h' (stk', loc', pc' - length ?pre, xcp')"
      by(rule exec_meth_drop_xt)(auto simp add: stack_xlift_compxE2)
    hence "?exec e1 stk STK loc pc xcp stk' loc' (pc' - length ?pre) xcp'"
      by(rule exec_meth_take_xt)(rule True)
    from IH[OF this] obtain stk'' where stk': "stk' = stk'' @ STK"
      and exec'': "exec_meth_d (compP2 P) (compE2 e1) (compxE2 e1 0 0) t h (stk, loc, pc, xcp)
      ta h' (stk'', loc', pc' - length ?pre, xcp')" by blast
    from exec'' have "exec_meth_d (compP2 P) (compE2 e1 @ Goto (1 + int (length (compE2 e2))) # compE2 e2)
      (compxE2 e1 0 0 @ shift (length (compE2 e1)) (compxE2 e2 (Suc 0) 0)) t
     h (stk, loc, pc, xcp) ta h' (stk'', loc', pc' - length ?pre, xcp')"
      by(rule exec_meth_append_xt)
    hence "exec_meth_d (compP2 P) (?pre @ compE2 e1 @ Goto (1 + int (length (compE2 e2))) # compE2 e2)
      (compxE2 e 0 0 @ shift (length ?pre) (compxE2 e1 0 0 @ shift (length (compE2 e1)) (compxE2 e2 (Suc 0) 0))) t
     h (stk, loc, length ?pre + pc, xcp) ta h' (stk'', loc', length ?pre + (pc' - length ?pre), xcp')"
      by(rule append_exec_meth_xt)(auto)
    moreover from exec' have "pc'  length ?pre"
      by(rule exec_meth_drop_xt_pc)(auto simp add: stack_xlift_compxE2)
    ultimately show ?thesis using stk'
      by(auto simp add: shift_compxE2 stack_xlift_compxE2 ac_simps)
  next
    case False
    with pc have [simp]: "pc = length (compE2 e1)" by simp
    from bisim obtain v where "stk = [v]" "xcp = None"
      by(auto dest: bisim1_pc_length_compE2D)
    with exec show ?thesis by(auto elim!: exec_meth.cases intro!: exec_meth.intros)
  qed
next
  case (bisim1CondElse e2 n e2' xs stk loc pc xcp e e1)
  note IH = stk' loc' pc' xcp' STK. ?exec e2 stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl e2 stk STK loc pc xcp stk' loc' pc' xcp'
  note exec = ?exec (if (e) e1 else e2) stk STK loc (Suc (Suc (length (compE2 e) + length (compE2 e1) + pc))) xcp stk' loc' pc' xcp'
  note bisim = P,e2,h  (e2', xs)  (stk, loc, pc, xcp)
  from bisim have pc: "pc  length (compE2 e2)" by(rule bisim1_pc_length_compE2)

  let ?pre = "compE2 e @ IfFalse (2 + int (length (compE2 e1))) # compE2 e1 @ [Goto (1 + int (length (compE2 e2)))]"
  from exec have exec': "exec_meth_d (compP2 P) (?pre @ compE2 e2)
    (stack_xlift (length STK) (compxE2 e 0 0 @ compxE2 e1 (Suc (length (compE2 e))) 0) @
     shift (length ?pre) (stack_xlift (length STK) (compxE2 e2 0 0))) t
    h (stk @ STK, loc, length ?pre + pc, xcp) ta h' (stk', loc', pc', xcp')"
    by(simp add: stack_xlift_compxE2 shift_compxE2 ac_simps)
  hence "?exec e2 stk STK loc pc xcp stk' loc' (pc' - length ?pre) xcp'"
    by(rule exec_meth_drop_xt)(auto simp add: stack_xlift_compxE2 shift_compxEs2 ac_simps)
  from IH[OF this] obtain stk'' where stk': "stk' = stk'' @ STK"
    and exec'': "exec_meth_d (compP2 P) (compE2 e2) (compxE2 e2 0 0) t h (stk, loc, pc, xcp)
    ta h' (stk'', loc', pc' - length ?pre, xcp')" by blast
  from exec'' have "exec_meth_d (compP2 P) (?pre @ compE2 e2)
    ((compxE2 e 0 0 @ compxE2 e1 (Suc (length (compE2 e))) 0) @ shift (length ?pre) (compxE2 e2 0 0)) t
    h (stk, loc, length ?pre + pc, xcp) ta h' (stk'', loc', length ?pre + (pc' - length ?pre), xcp')"
    by(rule append_exec_meth_xt)(auto)
  moreover from exec' have "pc'  length ?pre"
    by(rule exec_meth_drop_xt_pc)(auto simp add: stack_xlift_compxE2)
  moreover hence "(Suc (Suc (pc' - Suc (Suc 0)))) = pc'" by simp
  ultimately show ?case using stk'
    by(auto simp add: shift_compxE2 stack_xlift_compxE2 ac_simps eval_nat_numeral)
next
  case (bisim1CondThrow e n a xs stk loc pc e1 e2)
  note bisim = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  note IH = stk' loc' pc' xcp' STK. ?exec e stk STK loc pc a stk' loc' pc' xcp'
              ?concl e stk STK loc pc a stk' loc' pc' xcp'
  note exec = ?exec (if (e) e1 else e2) stk STK loc pc a stk' loc' pc' xcp'
  from bisim have pc: "pc < length (compE2 e)" by(auto dest: bisim1_ThrowD)
  from exec have "exec_meth_d (compP2 P) (compE2 e @ IfFalse (2 + int (length (compE2 e1))) # compE2 e1 @ Goto (1 + int (length (compE2 e2))) # compE2 e2)
     (stack_xlift (length STK) (compxE2 e 0 0) @ shift (length (compE2 e)) (stack_xlift (length STK) (compxE2 e1 (Suc 0) 0) @
      stack_xlift (length STK) (compxE2 e2 (Suc (Suc (length (compE2 e1)))) 0))) t
     h (stk @ STK, loc, pc, a) ta h' (stk', loc', pc', xcp')"
    by(simp add: stack_xlift_compxE2 shift_compxE2 ac_simps)
  hence "?exec e stk STK loc pc a stk' loc' pc' xcp'"
    by(rule exec_meth_take_xt)(rule pc)
  from IH[OF this] show ?case by auto
next
  case (bisim1While1 c n e xs)
  note IH = stk' loc' pc' xcp' STK. ?exec c [] STK xs 0 None stk' loc' pc' xcp'
              ?concl c [] STK xs 0 None stk' loc' pc' xcp'
  note exec = ?exec (while (c) e) [] STK xs 0 None stk' loc' pc' xcp'
  hence "exec_meth_d (compP2 P) (compE2 c @ IfFalse (int (length (compE2 e)) + 3) # compE2 e @ [Pop, Goto (-2 + (- int (length (compE2 e)) - int (length (compE2 c)))), Push Unit])
     (stack_xlift (length STK) (compxE2 c 0 0) @ shift (length (compE2 c)) (stack_xlift (length STK) (compxE2 e (Suc 0) 0))) t
     h ([] @ STK, xs, 0, None) ta h' (stk', loc', pc', xcp')"
    by(simp add: compxE2_size_convs)
  hence "?exec c [] STK xs 0 None stk' loc' pc' xcp'"
    by(rule exec_meth_take_xt) simp
  from IH[OF this] show ?case by auto
next
  case (bisim1While3 c n c' xs stk loc pc xcp e)
  note bisim = P,c,h  (c', xs)  (stk, loc, pc, xcp)
  note IH = stk' loc' pc' xcp' STK. ?exec c stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl c stk STK loc pc xcp stk' loc' pc' xcp'
  note exec = ?exec (while (c) e) stk STK loc pc xcp stk' loc' pc' xcp'
  from bisim have pc: "pc  length (compE2 c)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 c)")
    case True
    from exec have "exec_meth_d (compP2 P) (compE2 c @ IfFalse (int (length (compE2 e)) + 3) # compE2 e @ [Pop, Goto (-2 + (- int (length (compE2 e)) - int (length (compE2 c)))), Push Unit])
     (stack_xlift (length STK) (compxE2 c 0 0) @ shift (length (compE2 c)) (stack_xlift (length STK) (compxE2 e (Suc 0) 0))) t
      h (stk @ STK, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
      by(simp add: compxE2_size_convs)
    hence "?exec c stk STK loc pc xcp stk' loc' pc' xcp'"
      by(rule exec_meth_take_xt)(rule True)
    from IH[OF this] show ?thesis by auto
  next
    case False
    with pc have [simp]: "pc = length (compE2 c)" by simp
    from bisim obtain v where "stk = [v]" "xcp = None" by(auto dest: bisim1_pc_length_compE2D)
    with exec show ?thesis by(auto elim!: exec_meth.cases intro!: exec_meth.intros)
  qed
next
  case (bisim1While4 e n e' xs stk loc pc xcp c)
  note bisim = P,e,h  (e', xs)  (stk, loc, pc, xcp)
  note IH = stk' loc' pc' xcp' STK. ?exec e stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl e stk STK loc pc xcp stk' loc' pc' xcp'
  note exec = ?exec (while (c) e) stk STK loc (Suc (length (compE2 c) + pc)) xcp stk' loc' pc' xcp'
  from bisim have pc: "pc  length (compE2 e)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e)")
    case True
    let ?pre = "compE2 c @ [IfFalse (int (length (compE2 e)) + 3)]"
    from exec have "exec_meth_d (compP2 P) ((?pre @ compE2 e) @ [Pop, Goto (-2 + (- int (length (compE2 e)) - int (length (compE2 c)))), Push Unit])
                   (stack_xlift (length STK) (compxE2 c 0 0) @ shift (length ?pre) (stack_xlift (length STK) (compxE2 e 0 0))) t
                    h (stk @ STK, loc, length ?pre + pc, xcp) ta h' (stk', loc', pc', xcp')"
      by(simp add: compxE2_size_convs)
    hence exec': "exec_meth_d (compP2 P) (?pre @ compE2 e) (stack_xlift (length STK) (compxE2 c 0 0) @ shift (length ?pre) (stack_xlift (length STK) (compxE2 e 0 0))) t
                 h (stk @ STK, loc, length ?pre + pc, xcp) ta h' (stk', loc', pc', xcp')"
      by(rule exec_meth_take)(auto intro: True)
    hence "?exec e stk STK loc pc xcp stk' loc' (pc' - length ?pre) xcp'"
      by(rule exec_meth_drop_xt)(auto simp add: stack_xlift_compxE2)      
    from IH[OF this] obtain stk'' where stk': "stk' = stk'' @ STK"
      and exec'': "exec_meth_d (compP2 P) (compE2 e) (compxE2 e 0 0) t h (stk, loc, pc, xcp) ta h' (stk'', loc', pc' - length ?pre, xcp')" by auto
    from exec'' have "exec_meth_d (compP2 P) (?pre @ compE2 e) (compxE2 c 0 0 @ shift (length ?pre) (compxE2 e 0 0)) t
                     h (stk, loc, length ?pre + pc, xcp) ta h' (stk'', loc', length ?pre + (pc' - length ?pre), xcp')"
      by(rule append_exec_meth_xt) auto
    hence "exec_meth_d (compP2 P) ((?pre @ compE2 e) @ [Pop, Goto (-2 + (- int (length (compE2 e)) - int (length (compE2 c)))), Push Unit])
           (compxE2 c 0 0 @ shift (length ?pre) (compxE2 e 0 0)) t
           h (stk, loc, length ?pre + pc, xcp) ta h' (stk'', loc', length ?pre + (pc' - length ?pre), xcp')"
      by(rule exec_meth_append)
    moreover from exec' have "pc'  length ?pre"
     by(rule exec_meth_drop_xt_pc)(auto simp add: stack_xlift_compxE2)
   moreover have "-2 + (- int (length (compE2 e)) - int (length (compE2 c))) = - int (length (compE2 c)) + (-2 - int (length (compE2 e)))" by simp
   ultimately show ?thesis using stk'
     by(auto simp add: shift_compxE2 stack_xlift_compxE2 algebra_simps uminus_minus_left_commute)
 next
    case False
    with pc have [simp]: "pc = length (compE2 e)" by simp
    from bisim obtain v where "stk = [v]" "xcp = None" by(auto dest: bisim1_pc_length_compE2D)
    with exec show ?thesis by(auto elim!: exec_meth.cases intro!: exec_meth.intros)
  qed
next
  case (bisim1While6 c n e xs)
  note exec = ?exec (while (c) e) [] STK xs (Suc (Suc (length (compE2 c) + length (compE2 e)))) None stk' loc' pc' xcp'
  thus ?case by(rule exec_meth.cases)(simp_all, auto intro!: exec_meth.intros)
next
  case (bisim1While7 c n e xs)
  note exec = ?exec (while (c) e) [] STK xs (Suc (Suc (Suc (length (compE2 c) + length (compE2 e))))) None stk' loc' pc' xcp'
  thus ?case by(rule exec_meth.cases)(simp_all, auto intro!: exec_meth.intros)
next
  case (bisim1WhileThrow1 c n a xs stk loc pc e)
  note bisim = P,c,h  (Throw a, xs)  (stk, loc, pc, a)
  note IH = stk' loc' pc' xcp' STK. ?exec c stk STK loc pc a stk' loc' pc' xcp'
              ?concl c stk STK loc pc a stk' loc' pc' xcp'
  note exec = ?exec (while (c) e) stk STK loc pc a stk' loc' pc' xcp'
  from bisim have pc: "pc < length (compE2 c)" by(auto dest: bisim1_ThrowD)
  from exec have "exec_meth_d (compP2 P) (compE2 c @ IfFalse (int (length (compE2 e)) + 3) # compE2 e @ [Pop, Goto (-2 + (- int (length (compE2 e)) - int (length (compE2 c)))), Push Unit])
     (stack_xlift (length STK) (compxE2 c 0 0) @ shift (length (compE2 c)) (stack_xlift (length STK) (compxE2 e (Suc 0) 0))) t
     h (stk @ STK, loc, pc, a) ta h' (stk', loc', pc', xcp')"
    by(simp add: compxE2_size_convs)
  hence "?exec c stk STK loc pc a stk' loc' pc' xcp'"
    by(rule exec_meth_take_xt)(rule pc)
  from IH[OF this] show ?case by auto
next
  case (bisim1WhileThrow2 e n a xs stk loc pc c)
  note bisim = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  note IH = stk' loc' pc' xcp' STK. ?exec e stk STK loc pc a stk' loc' pc' xcp'
              ?concl e stk STK loc pc a stk' loc' pc' xcp'
  note exec = ?exec (while (c) e) stk STK loc (Suc (length (compE2 c) + pc)) a stk' loc' pc' xcp'
  from bisim have pc: "pc < length (compE2 e)" by(auto dest: bisim1_ThrowD)
  let ?pre = "compE2 c @ [IfFalse (int (length (compE2 e)) + 3)]"
  from exec have "exec_meth_d (compP2 P) ((?pre @ compE2 e) @ [Pop, Goto (-2 + (- int (length (compE2 e)) - int (length (compE2 c)))), Push Unit])
     (stack_xlift (length STK) (compxE2 c 0 0) @ shift (length ?pre) (stack_xlift (length STK) (compxE2 e 0 0))) t
    h (stk @ STK, loc, length ?pre + pc, a) ta h' (stk', loc', pc', xcp')"
    by(simp add: compxE2_size_convs)
  hence exec': "exec_meth_d (compP2 P) (?pre @ compE2 e)
    (stack_xlift (length STK) (compxE2 c 0 0) @ shift (length ?pre) (stack_xlift (length STK) (compxE2 e 0 0))) t
    h (stk @ STK, loc, (length ?pre + pc), a) ta h' (stk', loc', pc', xcp')"
    by(rule exec_meth_take)(auto intro: pc)
  hence "?exec e stk STK loc pc a stk' loc' (pc' - length ?pre) xcp'"
    by(rule exec_meth_drop_xt)(auto simp add: stack_xlift_compxE2)      
  from IH[OF this] obtain stk'' where stk': "stk' = stk'' @ STK"
    and exec'': "exec_meth_d (compP2 P) (compE2 e) (compxE2 e 0 0) t h (stk, loc, pc, a) ta h' (stk'', loc', pc' - length ?pre, xcp')" by auto
  from exec'' have "exec_meth_d (compP2 P) (?pre @ compE2 e) (compxE2 c 0 0 @ shift (length ?pre) (compxE2 e 0 0)) t
    h (stk, loc, length ?pre + pc, a) ta h' (stk'', loc', length ?pre + (pc' - length ?pre), xcp')"
    by(rule append_exec_meth_xt) auto
  hence "exec_meth_d (compP2 P) ((?pre @ compE2 e) @ [Pop, Goto (-2 + (- int (length (compE2 e)) - int (length (compE2 c)))), Push Unit])
    (compxE2 c 0 0 @ shift (length ?pre) (compxE2 e 0 0)) t
    h (stk, loc, length ?pre + pc, a) ta h' (stk'', loc', length ?pre + (pc' - length ?pre), xcp')"
    by(rule exec_meth_append)
  moreover from exec' have "pc'  length ?pre"
    by(rule exec_meth_drop_xt_pc)(auto simp add: stack_xlift_compxE2)
  moreover have "-2 + (- int (length (compE2 e)) - int (length (compE2 c))) = - int (length (compE2 c)) + (-2 - int (length (compE2 e)))" by simp
  ultimately show ?case using stk'
    by(auto simp add: shift_compxE2 stack_xlift_compxE2 algebra_simps uminus_minus_left_commute)
next
  case (bisim1Throw1 e n e' xs stk loc pc xcp)
  note bisim = P,e,h  (e', xs)  (stk, loc, pc, xcp)
  note IH = stk' loc' pc' xcp' STK. ?exec e stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl e stk STK loc pc xcp stk' loc' pc' xcp'
  note exec = ?exec (throw e) stk STK loc pc xcp stk' loc' pc' xcp'
  from bisim have pc: "pc  length (compE2 e)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e)")
    case True
    with exec have "?exec e stk STK loc pc xcp stk' loc' pc' xcp'" by(auto elim: exec_meth_take)
    from IH[OF this] show ?thesis by auto
  next
    case False
    with pc have [simp]: "pc = length (compE2 e)" by simp
    from bisim obtain v where "stk = [v]" "xcp = None" by(auto dest: bisim1_pc_length_compE2D)
    with exec show ?thesis by(auto elim!: exec_meth.cases intro!: exec_meth.intros split: if_split_asm)
  qed
next
  case bisim1Throw2 thus ?case
    apply(auto elim!:exec_meth.cases intro: exec_meth.intros dest!: match_ex_table_stack_xliftD)
    apply(auto intro: exec_meth.intros dest!: match_ex_table_stack_xliftD intro!: exI)
    apply(auto simp add: le_Suc_eq)
    done
next
  case bisim1ThrowNull thus ?case
    apply(auto elim!:exec_meth.cases intro: exec_meth.intros dest!: match_ex_table_stack_xliftD)
    apply(auto intro: exec_meth.intros dest!: match_ex_table_stack_xliftD intro!: exI)
    apply(auto simp add: le_Suc_eq)
    done
next
  case (bisim1ThrowThrow e n a xs stk loc pc)
  note bisim = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  note IH = stk' loc' pc' xcp' STK. ?exec e stk STK loc pc a stk' loc' pc' xcp'
              ?concl e stk STK loc pc a stk' loc' pc' xcp'
  note exec = ?exec (throw e) stk STK loc pc a stk' loc' pc' xcp'
  from bisim have pc: "pc < length (compE2 e)" by(auto dest: bisim1_ThrowD)
  with exec have "?exec e stk STK loc pc a stk' loc' pc' xcp'"
    by(auto elim: exec_meth_take simp add: compxE2_size_convs)
  from IH[OF this] show ?case by auto
next
  case (bisim1Try e n e' xs stk loc pc xcp e2 C' V)
  note bisim = P,e,h  (e', xs)  (stk, loc, pc, xcp)
  note IH = stk' loc' pc' xcp' STK. ?exec e stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl e stk STK loc pc xcp stk' loc' pc' xcp'
  note exec = ?exec (try e catch(C' V) e2) stk STK loc pc xcp stk' loc' pc' xcp'
  from bisim have pc: "pc  length (compE2 e)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e)")
    case True
    from exec have exec': "exec_meth_d (compP2 P) (compE2 e @ Goto (int (length (compE2 e2)) + 2) # Store V # compE2 e2)
      (stack_xlift (length STK) (compxE2 e 0 0) @  shift (length (compE2 e)) (stack_xlift (length STK) (compxE2 e2 (Suc (Suc 0)) 0)) @ [(0, length (compE2 e), C', Suc (length (compE2 e)), length STK)]) t
      h (stk @ STK, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
      by(simp add: compxE2_size_convs)
    show ?thesis
    proof(cases xcp)
      case None
      with exec' True have "?exec e stk STK loc pc xcp stk' loc' pc' xcp'"
        apply -
        apply (erule exec_meth.cases)
        apply (cases "compE2 e ! pc")
        apply (fastforce simp add: is_Ref_def intro: exec_meth.intros split: if_split_asm cong del: image_cong_simp)+
        done
      from IH[OF this] show ?thesis by auto
    next
      case (Some a)
      with exec' have [simp]: "h' = h" "loc' = loc" "xcp' = None" "ta = ε"
        by(auto elim: exec_meth.cases)
      show ?thesis
      proof(cases "match_ex_table (compP2 P) (cname_of h a) pc (compxE2 e 0 0)")
        case (Some pcd)
        from exec xcp = a Some pc
        have stk': "stk' = Addr a # (drop (length stk - snd pcd) stk) @ STK"
          by(auto elim!: exec_meth.cases simp add: match_ex_table_append split: if_split_asm dest!: match_ex_table_stack_xliftD)
        from exec' xcp = a Some pc have "exec_meth_d (compP2 P)
          (compE2 e) (stack_xlift (length STK) (compxE2 e 0 0)) t h (stk @ STK, loc, pc, a) ε h (Addr a # (drop (length (stk @ STK) - (snd pcd + length STK)) (stk @ STK)), loc, pc', None)"
          apply -
          apply(rule exec_meth.intros)
          apply(auto elim!: exec_meth.cases simp add: match_ex_table_append split: if_split_asm dest!: match_ex_table_shift_pcD match_ex_table_stack_xliftD)
          done
        from IH[unfolded ta = ε xcp = a h' = h, OF this]
        have stk: "Addr a # drop (length stk - snd pcd) (stk @ STK) = Addr a # drop (length stk - snd pcd) stk @ STK"
          and exec'': "exec_meth_d (compP2 P) (compE2 e) (compxE2 e 0 0) t h (stk, loc, pc, a) ε h (Addr a # drop (length stk - snd pcd) stk, loc, pc', None)" by auto
        thus ?thesis using Some stk' xcp = a by(auto)
      next
        case None
        with Some exec pc have stk': "stk' = Addr a # STK"
          and pc': "pc' = Suc (length (compE2 e))"
          and subcls: "compP2 P  cname_of h a * C'"
          by(auto elim!: exec_meth.cases split: if_split_asm simp add: match_ex_table_append_not_pcs)(simp add: matches_ex_entry_def)
        moreover from Some True None pc' subcls
        have "exec_meth_d (compP2 P) (compE2 (try e catch(C' V) e2)) (compxE2 (try e catch(C' V) e2) 0 0) t h
          (stk, loc, pc, a) ε h (Addr a # drop (length stk - 0) stk, loc, pc', None)"
          by -(rule exec_catch,auto simp add: match_ex_table_append_not_pcs matches_ex_entry_def)
        ultimately show ?thesis using Some by auto
      qed
    qed
  next
    case False
    with pc have [simp]: "pc = length (compE2 e)" by simp
    from bisim obtain v where "stk = [v]" "xcp = None" by(auto dest: bisim1_pc_length_compE2D)
    with exec show ?thesis by(auto elim!: exec_meth.cases intro!: exec_meth.intros split: if_split_asm)
  qed
next
  case bisim1TryCatch1 thus ?case
    by(auto elim!: exec_meth.cases intro!: exec_meth.intros split: if_split_asm)
next
  case (bisim1TryCatch2 e2 n e' xs stk loc pc xcp e C' V)
  note bisim = P,e2,h  (e', xs)  (stk, loc, pc, xcp)
  note IH = stk' loc' pc' xcp' STK. ?exec e2 stk STK loc pc xcp stk' loc' pc' xcp'
              ?concl e2 stk STK loc pc xcp stk' loc' pc' xcp'
  note exec = ?exec (try e catch(C' V) e2) stk STK loc (Suc (Suc (length (compE2 e) + pc))) xcp stk' loc' pc' xcp'
  let ?pre = "compE2 e @ [Goto (int (length (compE2 e2)) + 2), Store V]"
  from exec have exec': "exec_meth_d (compP2 P) (?pre @ compE2 e2)
    (stack_xlift (length STK) (compxE2 e 0 0) @ shift (length ?pre) (stack_xlift (length STK) (compxE2 e2 0 0))) t
    h (stk @ STK, loc, length ?pre + pc, xcp) ta h' (stk', loc', pc', xcp')"
  proof(cases)
    case (exec_catch xcp'' d)
    let ?stk = "stk @ STK" and ?PC = "Suc (Suc (length (compE2 e) + pc))"
    note s = stk' = Addr xcp'' # drop (length ?stk - d) ?stk
      ta = ε h' = h xcp' = None› xcp = xcp'' loc' = loc
    from ‹match_ex_table (compP2 P) (cname_of h xcp'') ?PC (stack_xlift (length STK) (compxE2 (try e catch(C' V) e2) 0 0)) = (pc', d) d  length ?stk
    show ?thesis unfolding s
      by -(rule exec_meth.exec_catch, simp_all add: shift_compxE2 stack_xlift_compxE2, simp add: match_ex_table_append add: matches_ex_entry_def)
  qed(auto intro: exec_meth.intros simp add: shift_compxE2 stack_xlift_compxE2)
  hence "?exec e2 stk STK loc pc xcp stk' loc' (pc' - length ?pre) xcp'"
    by(rule exec_meth_drop_xt)(auto simp add: stack_xlift_compxE2)
  from IH[OF this] obtain stk'' where stk': "stk' = stk'' @ STK"
    and exec'': "exec_meth_d (compP2 P) (compE2 e2) (compxE2 e2 0 0) t h (stk, loc, pc, xcp) ta h' (stk'', loc', pc' - length ?pre, xcp')" by auto
  from exec'' have "exec_meth_d (compP2 P) (?pre @ compE2 e2) (compxE2 e 0 0 @ shift (length ?pre) (compxE2 e2 0 0)) t h (stk, loc, length ?pre + pc, xcp) ta h' (stk'', loc', length ?pre + (pc' - length ?pre), xcp')"
    by(rule append_exec_meth_xt) auto
  hence "exec_meth_d (compP2 P) (?pre @ compE2 e2) (compxE2 e 0 0 @ shift (length ?pre) (compxE2 e2 0 0) @ [(0, length (compE2 e), C', Suc (length (compE2 e)), 0)]) t h (stk, loc, length ?pre + pc, xcp) ta h' (stk'', loc', length ?pre + (pc' - length ?pre), xcp')"
    by(rule exec_meth.cases)(auto intro: exec_meth.intros simp add: match_ex_table_append_not_pcs)
  moreover from exec' have "pc'  length ?pre"
    by(rule exec_meth_drop_xt_pc)(auto simp add: stack_xlift_compxE2)
  moreover hence "(Suc (Suc (pc' - Suc (Suc 0)))) = pc'" by simp
  ultimately show ?case using stk' by(auto simp add: shift_compxE2 eval_nat_numeral)
next
  case (bisim1TryFail e n a xs stk loc pc C' C'' e2 V)
  note bisim = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  note exec = ?exec (try e catch(C'' V) e2) stk STK loc pc a stk' loc' pc' xcp'
  note a = typeof_addr h a = Class_type C' ¬ P  C' * C''
  from bisim have "match_ex_table (compP2 P) (cname_of h a) (0 + pc) (compxE2 e 0 0) = None"
    unfolding compP2_def by(rule bisim1_xcp_Some_not_caught)
  moreover from bisim have "pc < length (compE2 e)" by(auto dest: bisim1_ThrowD)
  ultimately have False using exec a
    apply(auto elim!: exec_meth.cases simp add: outside_pcs_compxE2_not_matches_entry outside_pcs_not_matches_entry split: if_split_asm)
    apply(auto simp add: compP2_def match_ex_entry match_ex_table_append_not_pcs cname_of_def split: if_split_asm)
    done
  thus ?case ..
next
  case (bisim1TryCatchThrow e2 n a xs stk loc pc e C' V)
  note bisim = P,e2,h  (Throw a, xs)  (stk, loc, pc, a)
  note IH = stk' loc' pc' xcp' STK. ?exec e2 stk STK loc pc a stk' loc' pc' xcp'
              ?concl e2 stk STK loc pc a stk' loc' pc' xcp'
  note exec = ?exec (try e catch(C' V) e2) stk STK loc (Suc (Suc (length (compE2 e) + pc))) a stk' loc' pc' xcp'
  from bisim have pc: "pc < length (compE2 e2)" by(auto dest: bisim1_ThrowD)
  let ?pre = "compE2 e @ [Goto (int (length (compE2 e2)) + 2), Store V]"
  from exec have exec': "exec_meth_d (compP2 P) (?pre @ compE2 e2) (stack_xlift (length STK) (compxE2 e 0 0) @
    shift (length ?pre) (stack_xlift (length STK)  (compxE2 e2 0 0))) t
    h (stk @ STK, loc, length ?pre + pc, a) ta h' (stk', loc', pc', xcp')"
  proof(cases)
    case (exec_catch d)
    let ?stk = "stk @ STK" and ?PC = "Suc (Suc (length (compE2 e) + pc))"
    note s = stk' = Addr a # drop (length ?stk - d) ?stk loc' = loc
      ta = ε h' = h xcp' = None›
    from ‹match_ex_table (compP2 P) (cname_of h a) ?PC (stack_xlift (length STK) (compxE2 (try e catch(C' V) e2) 0 0)) = (pc', d) d  length ?stk
    show ?thesis unfolding s
      by -(rule exec_meth.exec_catch, simp_all add: shift_compxE2 stack_xlift_compxE2, simp add: match_ex_table_append add: matches_ex_entry_def)
  qed
  hence "?exec e2 stk STK loc pc a stk' loc' (pc' - length ?pre) xcp'"
    by(rule exec_meth_drop_xt)(auto simp add: stack_xlift_compxE2)
  from IH[OF this] obtain stk'' where stk': "stk' = stk'' @ STK"
    and exec'': "exec_meth_d (compP2 P) (compE2 e2) (compxE2 e2 0 0) t h (stk, loc, pc, a) ta h' (stk'', loc', pc' - length ?pre, xcp')" by auto
  from exec'' have "exec_meth_d (compP2 P) (?pre @ compE2 e2) (compxE2 e 0 0 @ shift (length ?pre) (compxE2 e2 0 0)) t h (stk, loc, length ?pre + pc, a) ta h' (stk'', loc', length ?pre + (pc' - length ?pre), xcp')"
    by(rule append_exec_meth_xt) auto
  hence "exec_meth_d (compP2 P) (?pre @ compE2 e2) (compxE2 e 0 0 @ shift (length ?pre) (compxE2 e2 0 0) @ [(0, length (compE2 e), C', Suc (length (compE2 e)), 0)]) t h (stk, loc, length ?pre + pc, a) ta h' (stk'', loc', length ?pre + (pc' - length ?pre), xcp')"
    by(rule exec_meth.cases)(auto intro!: exec_meth.intros simp add: match_ex_table_append_not_pcs)
  moreover from exec' have "pc'  length ?pre"
    by(rule exec_meth_drop_xt_pc)(auto simp add: stack_xlift_compxE2)
  moreover hence "(Suc (Suc (pc' - Suc (Suc 0)))) = pc'" by simp
  ultimately show ?case using stk' by(auto simp add: shift_compxE2 eval_nat_numeral)
next
  case bisims1Nil thus ?case by(auto elim: exec_meth.cases)
next
  case (bisims1List1 e n e' xs stk loc pc xcp es)
  note bisim1 = P,e,h  (e', xs )  (stk, loc, pc, xcp)
  note IH1 = stk' loc' pc' xcp' STK. ?exec e stk STK loc pc xcp stk' loc' pc' xcp'
               ?concl e stk STK loc pc xcp stk' loc' pc' xcp'
  note IH2 = xs stk' loc' pc' xcp' STK. ?execs es [] STK xs 0 None stk' loc' pc' xcp'
              ?concls es [] STK xs 0 None stk' loc' pc' xcp'
  note exec = ?execs (e # es) stk STK loc pc xcp stk' loc' pc' xcp'
  from bisim1 have pc: "pc  length (compE2 e)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e)")
    case True
    with exec have "?exec e stk STK loc pc xcp stk' loc' pc' xcp'"
      by(simp add: compxEs2_size_convs)(erule exec_meth_take_xt)
    from IH1[OF this] show ?thesis by auto
  next
    case False
    with pc have pc: "pc = length (compE2 e)" by simp
    with bisim1 obtain v where s: "stk = [v]" "xcp = None" by(auto dest: bisim1_pc_length_compE2D)
    with exec pc have exec': "exec_meth_d (compP2 P) (compE2 e @ compEs2 es)
      (stack_xlift (length STK) (compxE2 e 0 0) @ shift (length (compE2 e)) (stack_xlift (length (v # STK)) (compxEs2 es 0 0))) t
      h ([] @ v # STK, loc, length (compE2 e) + 0, None) ta h' (stk', loc', pc', xcp')"
      by(simp add: compxEs2_size_convs compxEs2_stack_xlift_convs)
    hence "?execs es [] (v # STK) loc 0 None stk' loc' (pc' - length (compE2 e)) xcp'"
      by(rule exec_meth_drop_xt)(auto simp add: stack_xlift_compxE2)
    from IH2[OF this] obtain stk'' where stk': "stk' = stk'' @ v # STK"
      and exec'': "exec_meth_d (compP2 P) (compEs2 es) (compxEs2 es 0 0) t h ([], loc, 0, None) ta h' (stk'', loc', pc' - length (compE2 e), xcp')" by auto
    from exec'' have "exec_meth_d (compP2 P) (compEs2 es) (stack_xlift (length [v]) (compxEs2 es 0 0)) t h ([] @ [v], loc, 0, None) ta h' (stk'' @ [v], loc', pc' - length (compE2 e), xcp')"
      by(rule exec_meth_stk_offer)
    hence "exec_meth_d (compP2 P) (compE2 e @ compEs2 es) (compxE2 e 0 0 @ shift (length (compE2 e)) (stack_xlift (length [v]) (compxEs2 es 0 0))) t h ([] @ [v], loc, length (compE2 e) + 0, None) ta h' (stk'' @ [v], loc', length (compE2 e) + (pc' - length (compE2 e)), xcp')"
      by(rule append_exec_meth_xt) auto
    moreover from exec' have "pc'  length (compE2 e)"
      by(rule exec_meth_drop_xt_pc)(auto simp add: stack_xlift_compxE2)
    ultimately show ?thesis using s pc stk' by(auto simp add: shift_compxEs2 stack_xlift_compxEs2)
  qed
next
  case (bisims1List2 es n es' xs stk loc pc xcp e v)
  note bisim = P,es,h  (es',xs) [↔] (stk,loc,pc,xcp)
  note IH = stk' loc' pc' xcp' STK. ?execs es stk STK loc pc xcp stk' loc' pc' xcp'
              ?concls es stk STK loc pc xcp stk' loc' pc' xcp'
  note exec = ?execs (e # es) (stk @ [v]) STK loc (length (compE2 e) + pc) xcp stk' loc' pc' xcp'
  from exec have exec': "exec_meth_d (compP2 P) (compE2 e @ compEs2 es)
     (stack_xlift (length STK) (compxE2 e 0 0) @ shift (length (compE2 e)) (stack_xlift (length (v # STK)) (compxEs2 es 0 0))) t
     h (stk @ v # STK, loc, length (compE2 e) + pc, xcp) ta h' (stk', loc', pc', xcp')"
    by(simp add: compxEs2_size_convs compxEs2_stack_xlift_convs)
  hence "?execs es stk (v # STK) loc pc xcp stk' loc' (pc' - length (compE2 e)) xcp'"
    by(rule exec_meth_drop_xt)(auto simp add: stack_xlift_compxE2)
  from IH[OF this] obtain stk'' where stk': "stk' = stk'' @ v # STK"
    and exec'': "exec_meth_d (compP2 P) (compEs2 es) (compxEs2 es 0 0) t h (stk, loc, pc, xcp) ta h' (stk'', loc', pc' - length (compE2 e), xcp')" by auto
  from exec'' have "exec_meth_d (compP2 P) (compEs2 es) (stack_xlift (length [v]) (compxEs2 es 0 0)) t h (stk @ [v], loc, pc, xcp) ta h' (stk'' @ [v], loc', pc' - length (compE2 e), xcp')"
    by(rule exec_meth_stk_offer)
  hence "exec_meth_d (compP2 P) (compE2 e @ compEs2 es) (compxE2 e 0 0 @ shift (length (compE2 e)) (stack_xlift (length [v]) (compxEs2 es 0 0))) t h (stk @ [v], loc, length (compE2 e) + pc, xcp) ta h' (stk'' @ [v], loc', length (compE2 e) + (pc' - length (compE2 e)), xcp')"
    by(rule append_exec_meth_xt) auto
  moreover from exec' have "pc'  length (compE2 e)"
    by(rule exec_meth_drop_xt_pc)(auto simp add: stack_xlift_compxE2)
  ultimately show ?case using stk' by(auto simp add: shift_compxEs2 stack_xlift_compxEs2)
next
  case (bisim1Sync12 e1 n e2 V a xs v v')
  note exec = ?exec (syncV (e1) e2) [v, v'] STK xs (4 + length (compE2 e1) + length (compE2 e2)) a stk' loc' pc' xcp'
  thus ?case by(auto elim!: exec_meth.cases split: if_split_asm simp add: match_ex_table_append_not_pcs)(simp add: matches_ex_entry_def)
next
  case (bisim1Sync14 e1 n e2 V a xs v a')
  note exec = ?exec (syncV (e1) e2) [v, Addr a'] STK xs (7 + length (compE2 e1) + length (compE2 e2)) a stk' loc' pc' xcp'
  thus ?case by(auto elim!: exec_meth.cases split: if_split_asm simp add: match_ex_table_append_not_pcs)(simp add: matches_ex_entry_def)
qed

lemma shows bisim1_callD:
  " P,e,h  (e', xs)  (stk, loc, pc, xcp); call1 e' = (a, M, vs);
     compE2 e ! pc = Invoke M' n0 
     M = M'"

  and bisims1_callD:
  " P,es,h  (es',xs) [↔] (stk,loc,pc, xcp); calls1 es' = (a, M, vs);
     compEs2 es ! pc = Invoke M' n0 
     M = M'"
proof(induct e "n :: nat" e' xs stk loc pc xcp and es "n :: nat" es' xs stk loc pc xcp
    rule: bisim1_bisims1_inducts_split)
  case bisim1AAss1 thus ?case
    apply(simp (no_asm_use) split: if_split_asm add: is_val_iff)
    apply(fastforce dest: bisim_Val_pc_not_Invoke)
    apply(fastforce dest: bisim_Val_pc_not_Invoke)
    apply(fastforce dest: bisim_Val_pc_not_Invoke bisim1_pc_length_compE2)+
    done
next
  case bisim1Call1 thus ?case
    apply(clarsimp split: if_split_asm simp add: is_vals_conv)
    apply(drule bisim_Val_pc_not_Invoke, simp, fastforce)
    apply(drule bisim_Val_pc_not_Invoke, simp, fastforce)
    apply(drule bisim1_pc_length_compE2, clarsimp simp add: neq_Nil_conv)
    apply(drule bisim1_pc_length_compE2, simp)
    apply(drule bisim1_pc_length_compE2, simp)
    apply(drule bisim1_pc_length_compE2, simp)
    apply(drule bisim1_call_pcD, simp, simp)
    apply(drule bisim1_call_pcD, simp, simp)
    done
next
  case bisim1CallParams thus ?case
    apply(clarsimp split: if_split_asm simp add: is_vals_conv)
    apply(drule bisims_Val_pc_not_Invoke, simp, fastforce)
    apply(drule bisims1_pc_length_compEs2, simp)
    apply(drule bisims1_calls_pcD, simp, simp)
    done
qed(fastforce split: if_split_asm dest: bisim1_pc_length_compE2 bisims1_pc_length_compEs2 bisim1_call_pcD bisims1_calls_pcD bisim1_call_xcpNone bisims1_calls_xcpNone bisim_Val_pc_not_Invoke bisims_Val_pc_not_Invoke)+

lemma bisim1_xcpD: "P,e,h  (e', xs)  (stk, loc, pc, a)  pc < length (compE2 e)"
  and bisims1_xcpD: "P,es,h  (es', xs) [↔] (stk, loc, pc, a)  pc < length (compEs2 es)"
by(induct "(e', xs)" "(stk, loc, pc, a :: 'addr)" and "(es', xs)" "(stk, loc, pc, a :: 'addr)"
  arbitrary: e' xs stk loc pc and es' xs stk loc pc rule: bisim1_bisims1.inducts)
  simp_all

lemma bisim1_match_Some_stk_length:
  " P,E,h  (e, xs)  (stk, loc, pc, a);
     match_ex_table (compP2 P) (cname_of h a) pc (compxE2 E 0 0) = (pc', d) 
   d  length stk"

  and bisims1_match_Some_stk_length:
  " P,Es,h  (es, xs) [↔] (stk, loc, pc, a);
     match_ex_table (compP2 P) (cname_of h a) pc (compxEs2 Es 0 0) = (pc', d) 
   d  length stk"
proof(induct "(e, xs)" "(stk, loc, pc, a :: 'addr)" and "(es, xs)" "(stk, loc, pc, a :: 'addr)"
  arbitrary: pc' d e xs stk loc pc and pc' d es xs stk loc pc rule: bisim1_bisims1.inducts)
  case bisim1Call1 thus ?case
    by(fastforce dest: bisim1_xcpD simp add: match_ex_table_append match_ex_table_not_pcs_None)
next
  case bisim1CallThrowObj thus ?case
    by(fastforce dest: bisim1_xcpD simp add: match_ex_table_append match_ex_table_not_pcs_None)
next
  case bisim1Sync4 thus ?case
    apply(clarsimp simp add: match_ex_table_not_pcs_None match_ex_table_append matches_ex_entry_def split: if_split_asm)
    apply(fastforce simp add: match_ex_table_compxE2_shift_conv dest: bisim1_xcpD)
    done
next
  case bisim1Try thus ?case
    by(fastforce simp add: match_ex_table_append matches_ex_entry_def match_ex_table_not_pcs_None dest: bisim1_xcpD split: if_split_asm)
next
  case bisim1TryCatch2 thus ?case
    apply(clarsimp simp add: match_ex_table_not_pcs_None match_ex_table_append matches_ex_entry_def split: if_split_asm)
    apply(fastforce simp add: match_ex_table_compxE2_shift_conv dest: bisim1_xcpD)
    done
next
  case bisim1TryFail thus ?case
    by(fastforce simp add: match_ex_table_append matches_ex_entry_def match_ex_table_not_pcs_None dest: bisim1_xcpD split: if_split_asm)
next
  case bisim1TryCatchThrow thus ?case
    apply(clarsimp simp add: match_ex_table_not_pcs_None match_ex_table_append matches_ex_entry_def split: if_split_asm)
    apply(fastforce simp add: match_ex_table_compxE2_shift_conv dest: bisim1_xcpD)
    done
next
  case bisims1List1 thus ?case
    by(fastforce simp add: match_ex_table_append split: if_split_asm dest: bisim1_xcpD match_ex_table_pcsD)
qed(fastforce simp add: match_ex_table_not_pcs_None match_ex_table_append match_ex_table_compxE2_shift_conv match_ex_table_compxEs2_shift_conv match_ex_table_compxE2_stack_conv match_ex_table_compxEs2_stack_conv matches_ex_entry_def dest: bisim1_xcpD)+

end

locale J1_JVM_heap_conf_base =
  J1_JVM_heap_base
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write 
  +
  J1_heap_conf_base
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write 
    hconf P 
  +
  JVM_heap_conf_base
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write 
    hconf "compP2 P"
  for addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and hconf :: "'heap  bool"
  and P :: "'addr J1_prog"
begin

inductive bisim1_list1 :: 
  "'thread_id  'heap  'addr expr1 × 'addr locals1  ('addr expr1 × 'addr locals1) list
   'addr option  'addr frame list  bool"
for t :: 'thread_id and h :: 'heap
where
  bl1_Normal:
  " compTP P  t:(xcp, h, (stk, loc, C, M, pc) # frs) ;
     P  C sees M : TsT = body in D;
     P,blocks1 0 (Class D#Ts) body, h  (e, xs)  (stk, loc, pc, xcp); max_vars e  length xs;
     list_all2 (bisim1_fr P h) exs frs 
   bisim1_list1 t h (e, xs) exs xcp ((stk, loc, C, M, pc) # frs)"

| bl1_finalVal:
  " hconf h; preallocated h   bisim1_list1 t h (Val v, xs) [] None []"

| bl1_finalThrow:
  " hconf h; preallocated h   bisim1_list1 t h (Throw a, xs) [] a []"

fun wbisim1 :: 
  "'thread_id
   ((('addr expr1 × 'addr locals1) × ('addr expr1 × 'addr locals1) list) × 'heap, 
      ('addr option × 'addr frame list) × 'heap) bisim"
where "wbisim1 t ((ex, exs), h) ((xcp, frs), h')  h = h'  bisim1_list1 t h ex exs xcp frs"

lemma new_thread_conf_compTP:
  assumes hconf: "hconf h" "preallocated h"
  and ha: "typeof_addr h a = Class_type C"
  and sub: "typeof_addr h (thread_id2addr t) = Class_type C'" "P  C' * Thread"
  and sees: "P  C sees M: []T = meth in D"
  shows "compTP P  t:(None, h, [([], Addr a # replicate (max_vars meth) undefined_value, D, M, 0)]) "
proof -
  from ha sees_method_decl_above[OF sees]
  have "P,h  Addr a :≤ Class D" by(simp add: conf_def)
  moreover
  hence "compP2 P,h  Addr a :≤ Class D" by(simp add: compP2_def)
  hence "compP2 P,h  Addr a # replicate (max_vars meth) undefined_value [:≤] map (λi. if i = 0 then OK ([Class D] ! i) else Err) [0..<max_vars meth] @ [Err]"
    by -(rule list_all2_all_nthI, simp_all)
  hence "conf_f (compP2 P) h ([], map (λi. if i = 0 then OK ([Class D] ! i) else Err) [0..<max_vars meth] @ [Err])
                (compE2 meth @ [Return]) ([], Addr a # replicate (max_vars meth) undefined_value, D, M, 0)"
    unfolding conf_f_def2 by(simp add: compP2_def)
  ultimately have "conf_f (compP2 P) h ([], TC0.tyl (Suc (max_vars meth)) [Class D] {0}) (compE2 meth @ [Return])
                       ([], Addr a # replicate (max_vars meth) undefined_value, D, M, 0)"
    by(simp add: TC0.tyl_def conf_f_def2 compP2_def)
  with hconf ha sub sees_method_compP[OF sees, where f="λC M Ts T. compMb2"] sees_method_idemp[OF sees]
  show ?thesis
    by(auto simp add: TC0.tyi'_def correct_state_def compTP_def tconf_def)(fastforce simp add: compP2_def compMb2_def tconf_def intro: sees_method_idemp)+
qed

lemma ta_bisim12_extTA2J1_extTA2JVM:
  assumes nt: "n T C M a h.  n < length tat; tat ! n = NewThread T (C, M, a) h  
            typeof_addr h a = Class_type C  (C'. typeof_addr h (thread_id2addr T) = Class_type C'  P  C' * Thread) 
              (T meth D. P  C sees M:[]T =meth in D)  hconf h  preallocated h"
  shows "ta_bisim wbisim1 (extTA2J1 P ta) (extTA2JVM (compP2 P) ta)"
proof -
  { fix n t C M a m
    assume "n < length tat" and "tat ! n = NewThread t (C, M, a) m"
    from nt[OF this] obtain T meth D C'
      where ma: "typeof_addr m a = Class_type C"
      and sees: "P  C sees M: []T = meth in D"
      and sub: "typeof_addr m (thread_id2addr t) = Class_type C'" "P  C' * Thread"
      and mconf: "hconf m" "preallocated m" by fastforce
    from sees_method_compP[OF sees, where f="λC M Ts T. compMb2"]
    have sees': "compP2 P  C sees M: []T = (max_stack meth, max_vars meth, compE2 meth @ [Return], compxE2 meth 0 0) in D"
      by(simp add: compMb2_def compP2_def)
    have "bisim1_list1 t m ({0:Class D=None; meth}, Addr a # replicate (max_vars meth) undefined_value) ([]) None [([], Addr a # replicate (max_vars meth) undefined_value, D, M, 0)]"
    proof
      from mconf ma sub sees
      show "compTP P  t:(None, m, [([], Addr a # replicate (max_vars meth) undefined_value, D, M, 0)]) "
        by(rule new_thread_conf_compTP)

      from sees show "P  D sees M: []T = meth in D" by(rule sees_method_idemp)
      show "list_all2 (bisim1_fr P m) [] []" by simp
      show "P,blocks1 0 [Class D] meth,m  ({0:Class D=None; meth}, Addr a # replicate (max_vars meth) undefined_value) 
                                                ([], Addr a # replicate (max_vars meth) undefined_value, 0, None)"
        by simp(rule bisim1_refl)
    qed simp
    with sees sees' have "bisim1_list1 t m ({0:Class (fst (method P C M))=None; the (snd (snd (snd (method P C M))))}, Addr a # replicate (max_vars (the (snd (snd (snd (method P C M)))))) undefined_value) [] None [([], Addr a # replicate (fst (snd (the (snd (snd (snd (method (compP2 P) C M))))))) undefined_value, fst (method (compP2 P) C M), M, 0)]" by simp }
  thus ?thesis
    apply(auto simp add: ta_bisim_def intro!: list_all2_all_nthI)
    apply(case_tac "tat ! n", auto simp add: extNTA2JVM_def)
    done
qed

end

definition no_call2 :: "'addr expr1  pc  bool"
where "no_call2 e pc  (pc  length (compE2 e))  (pc < length (compE2 e)  (M n. compE2 e ! pc  Invoke M n))"

definition no_calls2 :: "'addr expr1 list  pc  bool"
where "no_calls2 es pc  (pc  length (compEs2 es))  (pc < length (compEs2 es)  (M n. compEs2 es ! pc  Invoke M n))"

locale J1_JVM_conf_read =
  J1_JVM_heap_conf_base
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write
    hconf P 
  +
  JVM_conf_read
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write 
    hconf "compP2 P"
  for addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and hconf :: "'heap  bool"
  and P :: "'addr J1_prog"

locale J1_JVM_heap_conf =
  J1_JVM_heap_conf_base
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write 
    hconf P 
  +
  JVM_heap_conf
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write 
    hconf "compP2 P"
  for addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and hconf :: "'heap  bool"
  and P :: "'addr J1_prog"
begin

lemma red_external_ta_bisim21: 
  " wf_prog wf_md P; P,t  aM(vs), h -ta→ext va, h'; hconf h'; preallocated h' 
   ta_bisim wbisim1 (extTA2J1 P ta) (extTA2JVM (compP2 P) ta)"
apply(rule ta_bisim12_extTA2J1_extTA2JVM)
apply(frule (1) red_external_new_thread_sees)
 apply(fastforce simp add: in_set_conv_nth)
apply(frule red_ext_new_thread_heap)
 apply(fastforce simp add: in_set_conv_nth)
apply(frule red_external_new_thread_exists_thread_object[unfolded compP2_def, simplified])
 apply(fastforce simp add: in_set_conv_nth)
apply simp
done

lemma ta_bisim_red_extTA2J1_extTA2JVM:
  assumes wf: "wf_prog wf_md P"
  and red: "uf,P,t' ⊢1 e, s -ta e', s'"
  and hconf: "hconf (hp s')" "preallocated (hp s')"
  shows "ta_bisim wbisim1 (extTA2J1 P ta) (extTA2JVM (compP2 P) ta)"
proof -
  { fix n t C M a H
    assume len: "n < length tat" and tan: "tat ! n = NewThread t (C, M, a) H"
    hence nt: "NewThread t (C, M, a) H  set tat" unfolding set_conv_nth by(auto intro!: exI)
    from red1_new_threadD[OF red nt] obtain ad M' vs va T C' Ts' Tr' D'
      where rede: "P,t'  adM'(vs),hp s -ta→ext va,hp s'"
      and ad: "typeof_addr (hp s) ad = T" by blast
    from red_ext_new_thread_heap[OF rede nt] have [simp]: "hp s' = H" by simp
    from red_external_new_thread_sees[OF wf rede nt] 
    obtain T body D where Ha: "typeof_addr H a = Class_type C"
      and sees: "P  C sees M:[]T=body in D" by auto
    have sees': "compP2 P  C sees M:[]T=(max_stack body, max_vars body, compE2 body @ [Return], compxE2 body 0 0) in D"
      using sees unfolding compP2_def compMb2_def Let_def by(auto dest: sees_method_compP)
    from red_external_new_thread_exists_thread_object[unfolded compP2_def, simplified, OF rede nt] hconf Ha sees
    have "compTP P  t:(None, H, [([], Addr a # replicate (max_vars body) undefined_value, D, M, 0)]) "
      by(auto intro: new_thread_conf_compTP)
    hence "bisim1_list1 t H ({0:Class D=None; body}, Addr a # replicate (max_vars body) undefined_value) [] None [([], Addr a # replicate (max_vars body) undefined_value, D, M, 0)]"
    proof
      from sees show "P  D sees M:[]T=body in D" by(rule sees_method_idemp)

      show "P,blocks1 0 [Class D] body,H  ({0:Class D=None; body}, Addr a # replicate (max_vars body) undefined_value) 
                                                ([], Addr a # replicate (max_vars body) undefined_value, 0, None)"
        by(auto intro: bisim1_refl)
    qed simp_all
    hence "bisim1_list1 t H ({0:Class (fst (method P C M))=None; the (snd (snd (snd (method P C M))))},
                               Addr a # replicate (max_vars (the (snd (snd (snd (method P C M)))))) undefined_value)
                              []
                              None [([], Addr a # replicate (fst (snd (the (snd (snd (snd (method (compP2 P) C M))))))) undefined_value,
                                    fst (method (compP2 P) C M), M, 0)]"
      using sees sees' by simp }
  thus ?thesis
    apply(auto simp add: ta_bisim_def intro!: list_all2_all_nthI)
    apply(case_tac "tat ! n")
    apply(auto simp add: extNTA2JVM_def extNTA2J1_def)
    done
qed

end

sublocale J1_JVM_conf_read < heap_conf?: J1_JVM_heap_conf
by(unfold_locales)

sublocale J1_JVM_conf_read < heap?: J1_heap
apply(rule J1_heap.intro)
apply(subst compP_heap[symmetric, where f="λ_ _ _ _. compMb2", folded compP2_def])
apply(unfold_locales)
done

end

Theory J1JVM

(*  Title:      JinjaThreads/Compiler/J1JVM.thy
    Author:     Andreas Lochbihler
*)

section ‹Correctness of Stage: From intermediate language to JVM›

theory J1JVM imports J1JVMBisim begin

context J1_JVM_heap_base begin

declare τmove1.simps [simp del] τmoves1.simps [simp del]

lemma bisim1_insync_Throw_exec:
  assumes bisim2: "P,e2,h  (Throw ad, xs)  (stk, loc, pc, xcp)"
  shows "τExec_movet_a P t (syncV (e1) e2) h (stk, loc, Suc (Suc (Suc (length (compE2 e1) + pc))), xcp) ([Addr ad], loc, 6 + length (compE2 e1) + length (compE2 e2), None)"
proof -
  from bisim2 have pc: "pc < length (compE2 e2)" and [simp]: "xs = loc" by(auto dest: bisim1_ThrowD)
  let ?pc = "6 + length (compE2 e1) + length (compE2 e2)"
  let ?stk = "Addr ad # drop (size stk - 0) stk"
  from bisim2 have "xcp = ad  xcp = None" by(auto dest: bisim1_ThrowD)
  thus ?thesis
  proof
    assume [simp]: "xcp = ad"
    have "τExec_movet_a P t (syncV (e1) e2) h (stk, loc, Suc (Suc (Suc (length (compE2 e1) + pc))), ad) (?stk, loc, ?pc, None)"
    proof(rule τExect1step[unfolded exec_move_def, OF exec_catch])
      from bisim1_xcp_Some_not_caught[OF bisim2[simplified], of "λC M Ts T. compMb2" "Suc (Suc (Suc (length (compE2 e1))))" 0]
      have "match_ex_table (compP2 P) (cname_of h ad) (Suc (Suc (Suc (length (compE2 e1) + pc)))) (compxE2 e2 (Suc (Suc (Suc (length (compE2 e1))))) 0) = None"
        by(simp add: compP2_def)
      thus "match_ex_table (compP2 P) (cname_of h ad) (Suc (Suc (Suc (length (compE2 e1) + pc)))) (compxE2 (syncV (e1) e2) 0 0) = (6 + length (compE2 e1) + length (compE2 e2), 0)"
        using pc
        by(auto simp add: compP2_def match_ex_table_append matches_ex_entry_def eval_nat_numeral
                dest: match_ex_table_pc_length_compE2)
    qed(insert pc, auto intro: τmove2xcp)
    thus ?thesis by simp
  next
    assume [simp]: "xcp = None"
    with bisim2 obtain pc'
      where "τExec_movet_a P t e2 h (stk, loc, pc, None) ([Addr ad], loc, pc', ad)"
      and bisim': "P, e2, h  (Throw ad, xs)  ([Addr ad], loc, pc', ad)" and [simp]: "xs = loc"
      by(auto dest: bisim1_Throw_τExec_movet)
    hence "τExec_movet_a P t (syncV (e1) e2) h (stk, loc, Suc (Suc (Suc (length (compE2 e1) + pc))), None) ([Addr ad], loc, Suc (Suc (Suc (length (compE2 e1) + pc'))), ad)"
      by-(rule Insync_τExectI)
    also let ?stk = "Addr ad # drop (size [Addr ad] - 0) [Addr ad]"
    from bisim' have pc': "pc' < length (compE2 e2)" by(auto dest: bisim1_ThrowD)
    have "τExec_movet_a P t (syncV (e1) e2) h ([Addr ad], loc, Suc (Suc (Suc (length (compE2 e1) + pc'))), ad) (?stk, loc, ?pc, None)"
    proof(rule τExect1step[unfolded exec_move_def, OF exec_catch])
      from bisim1_xcp_Some_not_caught[OF bisim', of "λC M Ts T. compMb2" "Suc (Suc (Suc (length (compE2 e1))))" 0]
      have "match_ex_table (compP2 P) (cname_of h ad) (Suc (Suc (Suc (length (compE2 e1) + pc')))) (compxE2 e2 (Suc (Suc (Suc (length (compE2 e1))))) 0) = None"
        by(simp add: compP2_def)
      thus "match_ex_table (compP2 P) (cname_of h ad) (Suc (Suc (Suc (length (compE2 e1) + pc')))) (compxE2 (syncV (e1) e2) 0 0) = (6 + length (compE2 e1) + length (compE2 e2), 0)"
        using pc'
        by(auto simp add: compP2_def match_ex_table_append matches_ex_entry_def eval_nat_numeral
                dest: match_ex_table_pc_length_compE2)
    qed(insert pc', auto intro: τmove2xcp)
    finally (tranclp_trans) show ?thesis by simp
  qed
qed

end

primrec sim12_size :: "('a, 'b, 'addr) exp  nat"
  and sim12_sizes :: "('a, 'b, 'addr) exp list  nat"
where
  "sim12_size (new C) = 0"
| "sim12_size (newA Te) = Suc (sim12_size e)"
| "sim12_size (Cast T e) = Suc (sim12_size e)"
| "sim12_size (e instanceof T) = Suc (sim12_size e)"
| "sim12_size (e «bop» e') = Suc (sim12_size e + sim12_size e')"
| "sim12_size (Val v) = 0"
| "sim12_size (Var V) = 0"
| "sim12_size (V := e) = Suc (sim12_size e)"
| "sim12_size (ai) = Suc (sim12_size a + sim12_size i)"
| "sim12_size (ai := e) = Suc (sim12_size a + sim12_size i + sim12_size e)"
| "sim12_size (a∙length) = Suc (sim12_size a)"
| "sim12_size (eF{D}) = Suc (sim12_size e)"
| "sim12_size (eF{D} := e') = Suc (sim12_size e + sim12_size e')"
| "sim12_size (e∙compareAndSwap(DF, e', e'')) = Suc (sim12_size e + sim12_size e' + sim12_size e'')"
| "sim12_size (eM(es)) = Suc (sim12_size e + sim12_sizes es)"
| "sim12_size ({V:T=vo; e}) = Suc (sim12_size e)"
| "sim12_size (syncV(e) e') = Suc (sim12_size e + sim12_size e')"
| "sim12_size (insyncV(a) e) = Suc (sim12_size e)"
| "sim12_size (e;; e') = Suc (sim12_size e + sim12_size e')"
| "sim12_size (if (e) e1 else e2) = Suc (sim12_size e)"
| "sim12_size (while(b) c) = Suc (Suc (sim12_size b))"
| "sim12_size (throw e) = Suc (sim12_size e)"
| "sim12_size (try e catch(C V) e') = Suc (sim12_size e)"

| "sim12_sizes [] = 0"
| "sim12_sizes (e # es) = sim12_size e + sim12_sizes es"

lemma sim12_sizes_map_Val [simp]:
  "sim12_sizes (map Val vs) = 0"
by(induct vs) simp_all

lemma sim12_sizes_append [simp]:
  "sim12_sizes (es @ es') = sim12_sizes es + sim12_sizes es'"
by(induct es) simp_all

context JVM_heap_base begin

lemma τExec_mover_length_compE2_conv [simp]:
  assumes pc: "pc  length (compE2 e)"
  shows "τExec_mover ci P t e h (stk, loc, pc, xcp) s  s = (stk, loc, pc, xcp)"
proof
  assume "τExec_mover ci P t e h (stk, loc, pc, xcp) s"
  thus "s = (stk, loc, pc, xcp)" using pc
    by induct(auto simp add: τexec_move_def)
qed auto

lemma τExec_movesr_length_compE2_conv [simp]:
  assumes pc: "pc  length (compEs2 es)"
  shows "τExec_movesr ci P t es h (stk, loc, pc, xcp) s  s = (stk, loc, pc, xcp)"
proof
  assume "τExec_movesr ci P t es h (stk, loc, pc, xcp) s"
  thus "s = (stk, loc, pc, xcp)" using pc
    by induct(auto simp add: τexec_moves_def)
qed auto

end

context J1_JVM_heap_base begin

lemma assumes wf: "wf_J1_prog P"
  defines [simp]: "sim_move  λe e'. if sim12_size e' < sim12_size e then τExec_mover_a else τExec_movet_a"
  and [simp]: "sim_moves  λes es'. if sim12_sizes es' < sim12_sizes es then τExec_movesr_a else τExec_movest_a"
  shows exec_instr_simulates_red1:
  " P, E, h  (e, xs)  (stk, loc, pc, xcp); True,P,t ⊢1 e, (h, xs) -ta e', (h', xs'); bsok E n 
   pc'' stk'' loc'' xcp''. P, E, h'  (e', xs')  (stk'', loc'', pc'', xcp'') 
      (if τmove1 P h e
       then h = h'  sim_move e e' P t E h (stk, loc, pc, xcp) (stk'', loc'', pc'', xcp'')
       else pc' stk' loc' xcp'. τExec_mover_a P t E h (stk, loc, pc, xcp) (stk', loc', pc', xcp') 
                                 exec_move_a P t E h (stk', loc', pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'', loc'', pc'', xcp'') 
                                 ¬ τmove2 (compP2 P) h stk' E pc' xcp' 
                                 (call1 e = None  no_call2 E pc  pc' = pc  stk' = stk  loc' = loc  xcp' = xcp))"
  (is " _; _; _ 
        pc'' stk'' loc'' xcp''. _  ?exec ta E e e' h stk loc pc xcp h' pc'' stk'' loc'' xcp''")

  and exec_instr_simulates_reds1:  
  " P, Es, h  (es, xs) [↔] (stk, loc, pc, xcp); True,P,t ⊢1 es, (h, xs) [-ta→] es', (h', xs'); bsoks Es n 
   pc'' stk'' loc'' xcp''. P, Es, h'  (es', xs') [↔] (stk'', loc'', pc'', xcp'') 
      (if τmoves1 P h es
       then h = h'  sim_moves es es' P t Es h (stk, loc, pc, xcp) (stk'', loc'', pc'', xcp'')
       else pc' stk' loc' xcp'. τExec_movesr_a P t Es h (stk, loc, pc, xcp) (stk', loc', pc', xcp') 
                                 exec_moves_a P t Es h (stk', loc', pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'', loc'', pc'', xcp'')  
                                 ¬ τmoves2 (compP2 P) h stk' Es pc' xcp' 
                                 (calls1 es = None  no_calls2 Es pc  pc' = pc  stk' = stk  loc' = loc  xcp' = xcp))"
  (is " _; _; _ 
        pc'' stk'' loc'' xcp''. _  ?execs ta Es es es' h stk loc pc xcp h' pc'' stk'' loc'' xcp''")
proof(induction E n e xs stk loc pc xcp and Es n es xs stk loc pc xcp
    arbitrary: e' h' xs' Env T Env' T' and es' h' xs' Env Ts Env' Ts' rule: bisim1_bisims1_inducts_split)
  case (bisim1Call1 obj n obj' xs stk loc pc xcp ps M')
  note IHobj = bisim1Call1.IH(2)
  note IHparam = bisim1Call1.IH(4)
  note bisim1 = P,obj,h  (obj', xs)  (stk, loc, pc, xcp)
  note bisim2 = xs. P,ps,h  (ps, xs) [↔] ([], xs, 0, None)
  note bsok = ‹bsok (objM'(ps)) n
  note red = ‹True,P,t ⊢1 obj'M'(ps),(h, xs) -ta e',(h', xs')
  from red show ?case
  proof(cases)
    case (Call1Obj E')
    note [simp] = e' = E'M'(ps)
      and red = ‹True,P,t ⊢1 obj',(h, xs) -ta E',(h', xs')
    from red have τ: "τmove1 P h obj' = τmove1 P h (obj'M'(ps))" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover from red have "call1 (obj'M'(ps)) = call1 obj'" by auto
    moreover from IHobj[OF red] bsok
    obtain pc'' stk'' loc'' xcp'' where bisim: "P,obj,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and redo: "?exec ta obj obj' E' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    from bisim
    have "P,objM'(ps),h'  (E'M'(ps), xs')  (stk'', loc'', pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1Call1)
    moreover { 
      assume "no_call2 obj pc"
      hence "no_call2 (objM'(ps)) pc  pc = length (compE2 obj)" by(auto simp add: no_call2_def) }
    ultimately show ?thesis using redo
      by(auto simp del: call1.simps calls1.simps split: if_split_asm split del: if_split)(blast intro: Call_τExecrI1 Call_τExectI1 exec_move_CallI1)+
  next
    case (Call1Params es v)
    note [simp] = obj' = Val v e' = Val vM'(es)
      and red = ‹True,P,t ⊢1 ps, (h, xs) [-ta→] es, (h', xs')
    from red have τ: "τmove1 P h (obj'M'(ps)) = τmoves1 P h ps" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim1 have s: "xcp = None" "xs = loc"
      and execo: "τExec_mover_a P t obj h (stk, loc, pc, xcp) ([v], loc, length (compE2 obj), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (objM'(ps)) h (stk, loc, pc, xcp) ([v], loc, length (compE2 obj), None)"
      by-(rule Call_τExecrI1)
    moreover from IHparam[OF red] bsok obtain pc'' stk'' loc'' xcp''
      where bisim': "P,ps,h'  (es, xs') [↔] (stk'', loc'', pc'', xcp'')"
      and exec': "?execs ta ps ps es h [] xs 0 None h' pc'' stk'' loc'' xcp''" by auto
    have "?exec ta (objM'(ps)) (obj'M'(ps)) (obj'M(es)) h [v] loc (length (compE2 obj)) None h' (length (compE2 obj) + pc'') (stk'' @ [v]) loc'' xcp''"
    proof(cases "τmove1 P h (obj'M'(ps))")
      case True
      with exec' τ have [simp]: "h = h'"
        and e: "sim_moves ps es P t ps h ([], xs, 0, None) (stk'', loc'', pc'', xcp'')" by auto
      from e have "sim_move (obj'M'(ps)) (obj'M'(es)) P t (objM'(ps)) h ([] @ [v], xs, length (compE2 obj) + 0, None) (stk'' @ [v], loc'', length (compE2 obj) + pc'', xcp'')"
        by(fastforce dest: Call_τExecrI2 Call_τExectI2)
      with s True show ?thesis by auto
    next
      case False
      with exec' τ obtain pc' stk' loc' xcp'
        where e: "τExec_movesr_a P t ps h ([], xs, 0, None) (stk', loc', pc', xcp')"
        and e': "exec_moves_a P t ps h (stk', loc', pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'', loc'', pc'', xcp'')"
        and τ': "¬ τmoves2 (compP2 P) h stk' ps pc' xcp'" 
        and call: "calls1 ps = None  no_calls2 ps 0  pc' = 0  stk' = []  loc' = xs  xcp' = None" by auto
      from e have "τExec_mover_a P t (objM'(ps)) h ([] @ [v], xs, length (compE2 obj) + 0, None) (stk' @ [v], loc', length (compE2 obj) + pc', xcp')" by(rule Call_τExecrI2)
      moreover from e' have "exec_move_a P t (objM'(ps)) h (stk' @ [v], loc', length (compE2 obj) + pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'' @ [v], loc'', length (compE2 obj) + pc'', xcp'')"
        by(rule exec_move_CallI2)
      moreover from τ' e' have "τmove2 (compP2 P) h (stk' @ [v]) (objM'(ps)) (length (compE2 obj) + pc') xcp'  False"
        by(fastforce simp add: τmove2_iff τmoves2_iff τinstr_stk_drop_exec_moves split: if_split_asm)
      moreover from red have "call1 (obj'M'(ps)) = calls1 ps" by(auto simp add: is_vals_conv)
      moreover have "no_calls2 ps 0  no_call2 (objM'(ps)) (length (compE2 obj))  ps = []" "calls1 [] = None"
        by(auto simp add: no_calls2_def no_call2_def)
      ultimately show ?thesis using False s call
        by(auto simp del: split_paired_Ex call1.simps calls1.simps) blast
    qed
    moreover from bisim'
    have "P,objM'(ps),h'  (Val vM'(es), xs')  ((stk'' @ [v]), loc'', length (compE2 obj) + pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1CallParams)
    moreover from bisim1 have "pc  length (compE2 obj)  no_call2 (objM'(ps)) pc"
      by(auto simp add: no_call2_def dest: bisim_Val_pc_not_Invoke bisim1_pc_length_compE2)
    ultimately show ?thesis using τ execo
      apply(auto simp del: split_paired_Ex call1.simps calls1.simps split: if_split_asm split del: if_split)
      apply(blast intro: τExec_mover_trans|fastforce elim!: τExec_mover_trans simp del: split_paired_Ex call1.simps calls1.simps)+
      done
  next
    case (Call1ThrowObj a)
    note [simp] = obj' = Throw a ta = ε e' = Throw a h' = h xs' = xs
    have τ: "τmove1 P h (Throw aM'(ps))" by(rule τmove1CallThrowObj)
    from bisim1 have "xcp = a  xcp = None" by(auto dest: bisim1_ThrowD)
    thus ?thesis
    proof
      assume [simp]: "xcp = a"
      with bisim1 have "P, objM'(ps), h  (Throw a, xs)  (stk, loc, pc, a)"
        by(auto intro: bisim1_bisims1.bisim1CallThrowObj)
      thus ?thesis using τ by(fastforce)
    next
      assume [simp]: "xcp = None"
      with bisim1 obtain pc'
        where "τExec_mover_a P t obj h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        and bisim': "P, obj, h  (Throw a, xs)  ([Addr a], loc, pc', a)" and [simp]: "xs = loc"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t (objM'(ps)) h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        by-(rule Call_τExecrI1)
      moreover from bisim' have "P, objM'(ps), h  (Throw a, xs)  ([Addr a], loc, pc', a)"
        by(rule bisim1CallThrowObj)
      ultimately show ?thesis using τ by auto
    qed
  next
    case (Call1ThrowParams vs a es' v)
    note [simp] = obj' = Val v ta = ε e' = Throw a h' = h xs' = xs
      and ps = ps = map Val vs @ Throw a # es'
    from bisim1 have [simp]: "xcp = None" "xs = loc"
      and "τExec_mover_a P t obj h (stk, loc, pc, xcp) ([v], loc, length (compE2 obj), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (objM'(ps)) h (stk, loc, pc, xcp) ([v], loc, length (compE2 obj), None)"
      by-(rule Call_τExecrI1)
    also from bisims1_Throw_τExec_movest[OF bisim2[of xs, unfolded ps]]
    obtain pc' where exec': "τExec_movest_a P t (map Val vs @ Throw a # es') h ([], xs, 0, None) (Addr a # rev vs, xs, pc', a)"
      and bisim': "P,map Val vs @ Throw a # es',h  (map Val vs @ Throw a # es', xs) [↔] (Addr a # rev vs, xs, pc', a)"
      by auto
    from Call_τExectI2[OF exec', of "obj" M' v] ps
    have "τExec_movet_a P t (objM'(ps)) h ([v], loc, length (compE2 obj), None) (Addr a # rev vs @ [v], xs, length (compE2 obj) + pc', a)" by simp
    also from bisim1_bisims1.bisim1CallThrowParams[OF bisim', of obj M' v] ps
    have bisim'': "P,objM'(ps),h  (Throw a, xs)  (Addr a # rev vs @ [v], xs, length (compE2 obj) + pc', a)" by simp
    moreover have "τmove1 P h (obj'M'(ps))" using ps by(auto intro: τmove1CallThrowParams)
    ultimately show ?thesis by fastforce
  next
    case (Red1CallExternal a Ta Ts Tr D vs va H')
    hence [simp]: "obj' = addr a" "ps = map Val vs"
      "e' = extRet2J (addr aM'(map Val vs)) va" "H' = h'" "xs' = xs"
      and Ta: "typeof_addr h a = Ta"
      and iec: "P  class_type_of Ta sees M': TsTr = Native in D"
      and redex: "P,t  aM'(vs),h -ta→ext va,h'" by auto
    from bisim1 have [simp]: "xs = loc" by(auto dest: bisim_Val_loc_eq_xcp_None)
    have τ: "τmove1 P h (addr aM'(map Val vs))   τmove2 (compP2 P) h (rev vs @ [Addr a]) (objM'(ps)) (length (compE2 obj) + length (compEs2 ps)) None" using Ta iec
      by(auto simp add: map_eq_append_conv τmove1.simps τmoves1.simps τmove2_iff compP2_def)
    from bisim1 have s: "xcp = None" "lcl (h, xs) = loc"
      and "τExec_mover_a P t obj h (stk, loc, pc, xcp) ([Addr a], loc, length (compE2 obj), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (objM'(ps)) h (stk, loc, pc, xcp) ([Addr a], loc, length (compE2 obj), None)"
      by-(rule Call_τExecrI1)
    also have "τExec_movesr_a P t ps h ([], loc, 0, None) (rev vs, loc, length (compEs2 ps), None)"
      unfolding ps = map Val vs by(rule τExec_movesr_map_Val)
    from Call_τExecrI2[OF this, of obj M' "Addr a"]
    have "τExec_mover_a P t (objM'(ps)) h ([Addr a], loc, length (compE2 obj), None) (rev vs @ [Addr a], loc, length (compE2 obj) + length (compEs2 ps), None)" by simp
    also (rtranclp_trans) from bisim1 have "pc  length (compE2 obj)" by(rule bisim1_pc_length_compE2)
    hence "no_call2 (objM'(ps)) pc  pc = length (compE2 obj) + length (compEs2 ps)"
      using bisim1 by(fastforce simp add: no_call2_def neq_Nil_conv dest: bisim_Val_pc_not_Invoke)
    moreover { 
      assume "pc = length (compE2 obj) + length (compEs2 ps)"
      with ‹τExec_mover_a P t obj h (stk, loc, pc, xcp) ([Addr a], loc, length (compE2 obj), None)
      have "stk = rev vs @ [Addr a]" "xcp = None" by auto }
    moreover
    let ?ret = "extRet2JVM (length ps) h' (rev vs @ [Addr a]) loc undefined undefined (length (compE2 obj) + length (compEs2 ps)) [] va"
    let ?stk' = "fst (hd (snd (snd ?ret)))"
    let ?xcp' = "fst ?ret"
    let ?pc' = "snd (snd (snd (snd (hd (snd (snd ?ret))))))"
    from redex have redex': "(ta, va, h')  red_external_aggr (compP2 P) t a M' vs h"
      by -(rule red_external_imp_red_external_aggr, simp add: compP2_def)
    with Ta iec redex'
    have "exec_move_a P t (objM'(ps)) h (rev vs @ [Addr a], loc, length (compE2 obj) + length (compEs2 ps), None) (extTA2JVM (compP2 P) ta) h' (?stk', loc, ?pc', ?xcp')"
      unfolding exec_move_def
      by-(rule exec_instr,cases va,(force simp add: compP2_def simp del: split_paired_Ex)+)
    moreover have "P,objM'(ps),h'  (extRet2J1 (addr aM'(map Val vs)) va, loc)  (?stk', loc, ?pc', ?xcp')"
    proof(cases va)
      case (RetVal v)
      have "P,objM'(ps),h'  (Val v, loc)  ([v], loc, length (compE2 (objM'(ps))), None)"
        by(rule bisim1Val2) simp
      thus ?thesis unfolding RetVal by simp
    next
      case (RetExc ad) thus ?thesis by(auto intro: bisim1CallThrow)
    next
      case RetStaySame 
      from bisims1_map_Val_append[OF bisims1Nil, of "map Val vs" vs P h' loc]
      have "P,map Val vs,h'  (map Val vs, loc) [↔] (rev vs, loc, length (compEs2 (map Val vs)), None)" by simp
      hence "P,objM'(map Val vs),h'  (addr aM'(map Val vs), loc)  (rev vs @ [Addr a], loc, length (compE2 obj) + length (compEs2 (map Val vs)), None)"
        by(rule bisim1CallParams)
      thus ?thesis using RetStaySame by simp
    qed
    moreover from redex Ta iec
    have "τmove1 P h (addr aM'(map Val vs))  ta = ε  h' = h"
      by(fastforce simp add: τmove1.simps τmoves1.simps map_eq_append_conv τexternal'_def τexternal_def dest: τexternal'_red_external_heap_unchanged τexternal'_red_external_TA_empty sees_method_fun)
    ultimately show ?thesis using τ
      apply(cases "τmove1 P h (addr aM'(map Val vs) :: 'addr expr1)")
      apply(auto simp del: split_paired_Ex simp add: compP2_def)
      apply(blast intro: rtranclp.rtrancl_into_rtrancl rtranclp_into_tranclp1 τexec_moveI)+
      done
  next
    case (Red1CallNull vs)
    note [simp] = h' = h xs' = xs ta = ε obj' = null› ps = map Val vs e' = THROW NullPointer›
    from bisim1 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t obj h (stk, loc, pc, xcp) ([Null], loc, length (compE2 obj), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (objM'(map Val vs)) h (stk, loc, pc, xcp) ([Null], loc, length (compE2 obj), None)"
      by-(rule Call_τExecrI1)
    also have "τExec_movesr_a P t (map Val vs) h ([], loc, 0, None) (rev vs, loc, length (compEs2 (map Val vs)), None)"
    proof(cases "vs")
      case Nil thus ?thesis by(auto)
    next
      case Cons 
      with bisims1_refl[of P "h" "map Val vs" loc, simplified] show ?thesis
        by -(drule bisims1_Val_τExec_moves, auto)
    qed
    from Call_τExecrI2[OF this, of obj M' Null]
    have "τExec_mover_a P t (objM'(map Val vs)) h ([Null], loc, length (compE2 obj), None) (rev vs @ [Null], loc, length (compE2 obj) + length (compEs2 (map Val vs)), None)" by simp
    also (rtranclp_trans) {
      have "τmove2 (compP2 P) h (rev vs @ [Null]) (objM'(map Val vs)) (length (compE2 obj) + length (compEs2 (map Val vs))) None"
        by(simp add: τmove2_iff)
      moreover have "exec_move_a P t (objM'(map Val vs)) h (rev vs @ [Null], loc, length (compE2 obj) + length (compEs2 (map Val vs)), None) ε h (rev vs @ [Null], loc, length (compE2 obj) + length (compEs2 (map Val vs)), addr_of_sys_xcpt NullPointer)"
        unfolding exec_move_def by(cases vs)(auto intro: exec_instr)
      ultimately have "τExec_movet_a P t (objM'(map Val vs)) h  (rev vs @ [Null], loc, length (compE2 obj) + length (compEs2 (map Val vs)), None) (rev vs @ [Null], loc, length (compE2 obj) + length (compEs2 (map Val vs)), addr_of_sys_xcpt NullPointer)"
        by(auto intro: τexec_moveI simp add: compP2_def) }
    also have "τmove1 P h (nullM'(map Val vs))" by(auto simp add: τmove1.simps τmoves1.simps map_eq_append_conv)
    moreover have "P,objM'(map Val vs),h  (THROW NullPointer, loc)  ((rev vs @ [Null]), loc, length (compE2 obj) + length (compEs2 (map Val vs)), addr_of_sys_xcpt NullPointer)"
      by(rule bisim1CallThrow) simp
    ultimately show ?thesis using s by(auto simp del: split_paired_Ex)
  qed
next
  case bisim1Val2 thus ?case by fastforce
next
  case (bisim1New C' n xs)
  have τ: "¬ τmove1 P h (new C')" by(auto simp add: τmove1.simps τmoves1.simps)
  from ‹True,P,t ⊢1 new C',(h, xs) -ta e',(h', xs') show ?case
  proof cases
    case (Red1New a)
    hence "exec_meth_a (compP2 P) [New C'] [] t h ([], xs, 0, None) NewHeapElem a (Class_type C') h' ([Addr a], xs, Suc 0, None)"
      and [simp]: "e' = addr a" "xs' = xs" "ta = NewHeapElem a (Class_type C')"
      by (auto intro!: exec_instr simp add: compP2_def simp del: fun_upd_apply cong cong del: image_cong_simp)
    moreover have "P, new C', h'  (addr a, xs)  ([Addr a], xs, length (compE2 (new C')), None)"
      by(rule bisim1Val2)(simp)
    moreover have "¬ τmove2 (compP2 P) h [] (new C') 0 None" by(simp add: τmove2_iff)
    ultimately show ?thesis using τ 
      by(fastforce simp add: exec_move_def ta_upd_simps)
  next
    case Red1NewFail
    hence "exec_meth_a (compP2 P) [New C'] [] t h ([], xs, 0, None) ε h' ([], xs, 0, addr_of_sys_xcpt OutOfMemory)"
      and [simp]: "ta = ε" "xs' = xs" "e' = THROW OutOfMemory"
      by(auto intro!:exec_instr simp add: compP2_def simp del: fun_upd_apply)
    moreover have "P, new C', h'  (THROW OutOfMemory, xs)  ([], xs, 0, addr_of_sys_xcpt OutOfMemory)"
      by(rule bisim1NewThrow)
    moreover have "¬ τmove2 (compP2 P) h [] (new C') 0 None" by(simp add: τmove2_iff)
    ultimately show ?thesis using τ by(fastforce simp add: exec_move_def)
  qed
next
  case bisim1NewThrow thus ?case by fastforce
next
  case (bisim1NewArray E n e xs stk loc pc xcp U)
  note IH = bisim1NewArray.IH(2)
  note bisim = P,E,h  (e, xs)  (stk, loc, pc, xcp)
  note red = ‹True,P,t ⊢1 newA Ue,(h, xs) -ta e',(h', xs')
  note bsok = ‹bsok (newA UE) n
  from red show ?case
  proof cases 
    case (New1ArrayRed ee')
    note [simp] = e' = newA Uee'
      and red = ‹True,P,t ⊢1 e,(h, xs) -ta ee', (h', xs')
    from red have "τmove1 P h (newA Ue) = τmove1 P h e" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover from red have "call1 (newA Ue) = call1 e" by auto
    moreover from IH[OF red] bsok
    obtain pc'' stk'' loc'' xcp'' where bisim: "P,E,h'  (ee', xs')  (stk'', loc'', pc'', xcp'')"
      and redo: "?exec ta E e ee' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    from bisim
    have "P,newA UE,h'  (newA Uee', xs')  (stk'', loc'', pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1NewArray)
    moreover { 
      assume "no_call2 E pc"
      hence "no_call2 (newA UE) pc" by(auto simp add: no_call2_def) }
    ultimately show ?thesis using redo
      by(auto simp del: call1.simps calls1.simps split: if_split_asm split del: if_split)(blast intro: NewArray_τExecrI NewArray_τExectI exec_move_newArrayI)+
  next
    case (Red1NewArray i a)
    note [simp] = e = Val (Intg i) ta = NewHeapElem a (Array_type U (nat (sint i))) e' = addr a xs' = xs
      and new = (h', a)  allocate h (Array_type U (nat (sint i)))
    from bisim have s: "xcp = None" "xs = loc" by(auto dest: bisim_Val_loc_eq_xcp_None)
    from bisim have "τExec_mover_a P t E h (stk, loc, pc, xcp) ([Intg i], loc, length (compE2 E), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (newA UE) h (stk, loc, pc, xcp) ([Intg i], loc, length (compE2 E), None)"
      by(rule NewArray_τExecrI)
    moreover from new 0 <=s i
    have "exec_move_a P t (newA UE) h ([Intg i], loc, length (compE2 E), None) NewHeapElem a (Array_type U (nat (sint i))) h' ([Addr a], loc, Suc (length (compE2 E)), None)"
      by (auto intro!: exec_instr simp add: compP2_def exec_move_def cong del: image_cong_simp)
    moreover have "τmove2 (compP2 P) h [Intg i] (newA UE) (length (compE2 E)) None  False" by(simp add: τmove2_iff)
    moreover have "¬ τmove1 P h (newA UVal (Intg i))" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover have "P, newA UE, h'  (addr a, loc)  ([Addr a], loc, length (compE2 (newA UE)), None)"
      by(rule bisim1Val2) simp
    ultimately show ?thesis using s by(auto simp del: fun_upd_apply simp add: ta_upd_simps) blast
  next
    case (Red1NewArrayNegative i)
    note [simp] = e = Val (Intg i) e' = THROW NegativeArraySize› h' = h xs' = xs ta = ε
    have "¬ τmove1 P h (newA UVal (Intg i))" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover from bisim have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t E h (stk, loc, pc, xcp) ([Intg i], loc, length (compE2 E), None)"
      by(auto dest: bisim1Val2D1)
    moreover from i <s 0
    have "exec_meth_a (compP2 P) (compE2 (newA UE)) (compxE2 (newA UE) 0 0) t h ([Intg i], loc, length (compE2 E), None) ε h ([Intg i], loc, length (compE2 E), addr_of_sys_xcpt NegativeArraySize)"
      by -(rule exec_instr, auto simp add: compP2_def)
    moreover have "τmove2 (compP2 P) h [Intg i] (newA UE) (length (compE2 E)) None  False" by(simp add: τmove2_iff)
    moreover
    have "P,newA UE,h  (THROW NegativeArraySize, loc)  ([Intg i], loc, length (compE2 E), addr_of_sys_xcpt NegativeArraySize)"
      by(auto intro!: bisim1_bisims1.bisim1NewArrayFail)
    ultimately show ?thesis using s 
      by(auto simp add: exec_move_def)(blast intro: NewArray_τExecrI)
  next
    case (Red1NewArrayFail i)
    note [simp] = e = Val (Intg i) e' = THROW OutOfMemory› xs' = xs ta = ε h' = h
      and new = allocate h (Array_type U (nat (sint i))) = {}
    have "¬ τmove1 P h (newA UVal (Intg i))" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover from bisim have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t E h (stk, loc, pc, xcp) ([Intg i], loc, length (compE2 E), None)"
      by(auto dest: bisim1Val2D1)
    moreover from 0 <=s i new
    have "exec_meth_a (compP2 P) (compE2 (newA UE)) (compxE2 (newA UE) 0 0) t h ([Intg i], loc, length (compE2 E), None) ε h' ([Intg i], loc, length (compE2 E), addr_of_sys_xcpt OutOfMemory)"
      by -(rule exec_instr, auto simp add: compP2_def)
    moreover have "τmove2 (compP2 P) h [Intg i] (newA UE) (length (compE2 E)) None  False" by(simp add: τmove2_iff)
    moreover
    have "P,newA UE,h'  (THROW OutOfMemory, loc)  ([Intg i], loc, length (compE2 E), addr_of_sys_xcpt OutOfMemory)"
      by(auto intro!: bisim1_bisims1.bisim1NewArrayFail)
    ultimately show ?thesis using s by (auto simp add: exec_move_def)(blast intro: NewArray_τExecrI)
  next
    case (New1ArrayThrow a)
    note [simp] = e = Throw a h' = h xs' = xs ta = ε e' = Throw a
    have τ: "τmove1 P h (newA Ue)" by(auto intro: τmove1NewArrayThrow)
    from bisim have "xcp = a  xcp = None" by(auto dest: bisim1_ThrowD)
    thus ?thesis
    proof
      assume [simp]: "xcp = a"
      with bisim have "P,newA UE, h  (Throw a, xs)  (stk, loc, pc, xcp)"
        by(auto intro: bisim1_bisims1.bisim1NewArrayThrow)
      thus ?thesis using τ by(fastforce)
    next
      assume [simp]: "xcp = None"
      with bisim obtain pc'
        where "τExec_mover_a P t E h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        and bisim': "P, E, h  (Throw a, xs)  ([Addr a], loc, pc', a)" and [simp]: "xs = loc"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t (newA UE) h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        by-(rule NewArray_τExecrI)
      moreover from bisim' have "P, newA UE, h  (Throw a, xs)  ([Addr a], loc, pc', a)"
        by(rule bisim1_bisims1.bisim1NewArrayThrow)
      ultimately show ?thesis using τ by auto
    qed
  qed
next
  case bisim1NewArrayThrow thus ?case by auto
next
  case bisim1NewArrayFail thus ?case by auto
next
  case (bisim1Cast E n e xs stk loc pc xcp U)
  note IH = bisim1Cast.IH(2)
  note bisim = P,E,h  (e, xs)  (stk, loc, pc, xcp)
  note red = ‹True,P,t ⊢1 Cast U e,(h, xs) -ta e',(h', xs')
  note bsok = ‹bsok (Cast U E) n
  from red show ?case
  proof cases
    case (Cast1Red ee')
    note [simp] = e' = Cast U ee'
      and red = ‹True,P,t ⊢1 e,(h, xs) -ta ee', (h', xs')
    from red have "τmove1 P h (Cast U e) = τmove1 P h e" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover from red have "call1 (Cast U e) = call1 e" by auto
    moreover from IH[OF red] bsok
    obtain pc'' stk'' loc'' xcp'' where bisim: "P,E,h'  (ee', xs')  (stk'', loc'', pc'', xcp'')"
      and redo: "?exec ta E e ee' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    from bisim
    have "P,Cast U E,h'  (Cast U ee', xs')  (stk'', loc'', pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1Cast)
    moreover { 
      assume "no_call2 E pc"
      hence "no_call2 (Cast U E) pc" by(auto simp add: no_call2_def) }
    ultimately show ?thesis using redo
      by(auto simp del: call1.simps calls1.simps split: if_split_asm split del: if_split)(blast intro: Cast_τExecrI Cast_τExectI exec_move_CastI)+
  next
    case (Red1Cast c U')
    hence [simp]: "e = Val c" "ta = ε" "e' = Val c" "h' = h" "xs' = xs"
      and type: "typeofh c = U'" "P  U'  U" by auto
    from bisim have s: "xcp = None" "xs = loc" by(auto dest: bisim_Val_loc_eq_xcp_None)
    from bisim have "τExec_mover_a P t E h (stk, loc, pc, xcp) ([c], loc, length (compE2 E), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (Cast U E) h (stk, loc, pc, xcp) ([c], loc, length (compE2 E), None)"
      by(rule Cast_τExecrI)
    moreover from type
    have "exec_meth_a (compP2 P) (compE2 (Cast U E)) (compxE2 (Cast U E) 0 0) t h ([c], loc, length (compE2 E), None) ε h' ([c], loc, Suc (length (compE2 E)), None)"
      by(auto intro!: exec_instr simp add: compP2_def)
    moreover have "τmove2 (compP2 P) h [c] (Cast U E) (length (compE2 E)) None" by(simp add: τmove2_iff)
    ultimately have "τExec_mover_a P t (Cast U E) h (stk, loc, pc, xcp) ([c], loc, Suc (length (compE2 E)), None)"
      by(fastforce elim: rtranclp.rtrancl_into_rtrancl intro: τexec_moveI simp add: exec_move_def compP2_def)
    moreover have "τmove1 P h (Cast U (Val c))" by(rule τmove1CastRed)
    moreover 
    have "P, Cast U E, h'  (Val c, loc)  ([c], loc, length (compE2 (Cast U E)), None)"
      by(rule bisim1Val2) simp
    ultimately show ?thesis using s by(auto simp add: exec_move_def)
  next
    case (Red1CastFail v U')
    note [simp] = e = Val v e' = THROW ClassCast› h' = h xs' = xs ta = ε
    moreover from bisim have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t E h (stk, loc, pc, xcp) ([v], loc, length (compE2 E), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (Cast U E) h (stk, loc, pc, xcp) ([v], loc, length (compE2 E), None)"
      by(auto elim: Cast_τExecrI)
    moreover from ‹typeofhp (h, xs) v = U' ¬ P  U'  U
    have "exec_meth_a (compP2 P) (compE2 (Cast U E)) (compxE2 (Cast U E) 0 0) t h ([v], loc, length (compE2 E), None) ε h ([v], loc, length (compE2 E), addr_of_sys_xcpt ClassCast)"
      by -(rule exec_instr, auto simp add: compP2_def)
    moreover have "τmove2 (compP2 P) h [v] (Cast U E) (length (compE2 E)) None" by(simp add: τmove2_iff)
    ultimately have "τExec_movet_a P t (Cast U E) h (stk, loc, pc, xcp) ([v], loc, length (compE2 E), addr_of_sys_xcpt ClassCast)"
      by(fastforce simp add: exec_move_def compP2_def intro: rtranclp_into_tranclp1 τexec_moveI)
    moreover have "τmove1 P h (Cast U (Val v))" by(rule τmove1CastRed)
    moreover
    have "P,Cast U E,h  (THROW ClassCast, loc)  ([v], loc, length (compE2 E), addr_of_sys_xcpt ClassCast)"
      by(auto intro!: bisim1_bisims1.bisim1CastFail)
    ultimately show ?thesis using s by(auto simp add: exec_move_def)
  next
    case [simp]: (Cast1Throw a)
    have τ: "τmove1 P h (Cast U e)" by(auto intro: τmove1CastThrow)
    from bisim have "xcp = a  xcp = None" by(auto dest: bisim1_ThrowD)
    thus ?thesis
    proof
      assume [simp]: "xcp = a"
      with bisim have "P,Cast U E, h  (Throw a, xs)  (stk, loc, pc, xcp)"
        by(auto intro: bisim1_bisims1.bisim1CastThrow)
      thus ?thesis using τ by(fastforce)
    next
      assume [simp]: "xcp = None"
      with bisim obtain pc'
        where "τExec_mover_a P t E h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        and bisim': "P, E, h  (Throw a, xs)  ([Addr a], loc, pc', a)" and [simp]: "xs = loc"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t (Cast U E) h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        by-(rule Cast_τExecrI)
      moreover from bisim' have "P, Cast U E, h  (Throw a, xs)  ([Addr a], loc, pc', a)"
        by-(rule bisim1_bisims1.bisim1CastThrow, auto)
      ultimately show ?thesis using τ by auto
    qed
  qed
next
  case bisim1CastThrow thus ?case by auto
next
  case bisim1CastFail thus ?case by auto
next
  case (bisim1InstanceOf E n e xs stk loc pc xcp U)
  note IH = bisim1InstanceOf(2)
  note bisim = P,E,h  (e, xs)  (stk, loc, pc, xcp)
  note red = ‹True,P,t ⊢1 e instanceof U,(h, xs) -ta e',(h', xs')
  note bsok = ‹bsok (E instanceof U) n
  from red show ?case
  proof cases
    case (InstanceOf1Red ee')
    note [simp] = e' = ee' instanceof U
      and red = ‹True,P,t ⊢1 e,(h, xs) -ta ee', (h', xs')
    from red have "τmove1 P h (e instanceof U) = τmove1 P h e" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover from red have "call1 (e instanceof U) = call1 e" by auto
    moreover from IH[OF red] bsok
    obtain pc'' stk'' loc'' xcp'' where bisim: "P,E,h'  (ee', xs')  (stk'', loc'', pc'', xcp'')"
      and redo: "?exec ta E e ee' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    from bisim
    have "P,E instanceof U,h'  (ee' instanceof U, xs')  (stk'', loc'', pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1InstanceOf)
    moreover { 
      assume "no_call2 E pc"
      hence "no_call2 (E instanceof U) pc" by(auto simp add: no_call2_def) }
    ultimately show ?thesis using redo
      by(auto simp del: call1.simps calls1.simps split: if_split_asm split del: if_split)(blast intro: InstanceOf_τExecrI InstanceOf_τExectI exec_move_InstanceOfI)+
  next
    case (Red1InstanceOf c U' b)
    hence [simp]: "e = Val c" "ta = ε" "e' = Val (Bool (c  Null  P  U'  U))" "h' = h" "xs' = xs"
      "b = (c  Null  P  U'  U)"
      and type: "typeofh c = U'" by auto
    from bisim have s: "xcp = None" "xs = loc" by(auto dest: bisim_Val_loc_eq_xcp_None)
    from bisim have "τExec_mover_a P t E h (stk, loc, pc, xcp) ([c], loc, length (compE2 E), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (E instanceof U) h (stk, loc, pc, xcp) ([c], loc, length (compE2 E), None)"
      by(rule InstanceOf_τExecrI)
    moreover from type
    have "exec_meth_a (compP2 P) (compE2 (E instanceof U)) (compxE2 (E instanceof U) 0 0) t h ([c], loc, length (compE2 E), None) ε h' ([Bool b], loc, Suc (length (compE2 E)), None)"
      by(auto intro!: exec_instr simp add: compP2_def)
    moreover have "τmove2 (compP2 P) h [c] (E instanceof U) (length (compE2 E)) None" by(simp add: τmove2_iff)
    ultimately have "τExec_mover_a P t (E instanceof U) h (stk, loc, pc, xcp) ([Bool b], loc, Suc (length (compE2 E)), None)"
      by(fastforce elim: rtranclp.rtrancl_into_rtrancl intro: τexec_moveI simp add: exec_move_def compP2_def)
    moreover have "τmove1 P h ((Val c) instanceof U)" by(rule τmove1InstanceOfRed)
    moreover
    have "P, E instanceof U, h'  (Val (Bool b), loc)  ([Bool b], loc, length (compE2 (E instanceof U)), None)"
      by(rule bisim1Val2) simp
    ultimately show ?thesis using s by(auto simp add: exec_move_def)
  next
    case (InstanceOf1Throw a)
    note [simp] = e = Throw a h' = h xs' = xs ta = ε e' = Throw a
    have τ: "τmove1 P h (e instanceof U)" by(auto intro: τmove1InstanceOfThrow)
    from bisim have "xcp = a  xcp = None" by(auto dest: bisim1_ThrowD)
    thus ?thesis
    proof
      assume [simp]: "xcp = a"
      with bisim have "P,E instanceof U, h  (Throw a, xs)  (stk, loc, pc, xcp)"
        by(auto intro: bisim1_bisims1.bisim1InstanceOfThrow)
      thus ?thesis using τ by(fastforce)
    next
      assume [simp]: "xcp = None"
      with bisim obtain pc'
        where "τExec_mover_a P t E h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        and bisim': "P, E, h  (Throw a, xs)  ([Addr a], loc, pc', a)" and [simp]: "xs = loc"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t (E instanceof U) h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        by-(rule InstanceOf_τExecrI)
      moreover from bisim' have "P, E instanceof U, h  (Throw a, xs)  ([Addr a], loc, pc', a)"
        by-(rule bisim1_bisims1.bisim1InstanceOfThrow, auto)
      ultimately show ?thesis using τ by auto
    qed
  qed
next
  case bisim1InstanceOfThrow thus ?case by auto
next
  case bisim1Val thus ?case by fastforce
next
  case (bisim1Var V n xs)
  from ‹True,P,t ⊢1 Var V,(h, xs) -ta e',(h', xs') show ?case
  proof cases
    case (Red1Var v)
    hence "exec_meth_a (compP2 P) [Load V] [] t h ([], xs, 0, None) ε h ([v], xs, 1, None)"
      and [simp]: "ta = ε" "h' = h" "xs' = xs" "e' = Val v"
      by(auto intro: exec_instr)
    moreover have "τmove2 (compP2 P) h [] (Var V) 0 None" by(simp add: τmove2_iff)
    ultimately have "τExec_movet_a P t (Var V) h ([], xs, 0, None) ([v], xs, 1, None)"
      by(auto intro: τExect1step simp add: exec_move_def compP2_def)
    moreover have "P, Var V, h  (Val v, xs)  ([v], xs, length (compE2 (Var V)), None)"
      by(rule bisim1Val2) simp
    moreover have "τmove1 P h (Var V)" by(rule τmove1Var)
    ultimately show ?thesis by(fastforce)
  qed
next
  case (bisim1BinOp1 e1 n e1' xs stk loc pc xcp e2 bop)
  note IH1 = bisim1BinOp1.IH(2)
  note IH2 = bisim1BinOp1.IH(4)
  note bisim1 = P,e1,h  (e1', xs)  (stk, loc, pc, xcp)
  note bisim2 = xs. P,e2,h  (e2, xs)  ([], xs, 0, None)
  note bsok = ‹bsok (e1 «bop» e2) n
  from ‹True,P,t ⊢1 e1' «bop» e2,(h, xs) -ta e',(h', xs') show ?case
  proof cases
    case (Bin1OpRed1 E')
    note [simp] = e' = E' «bop» e2
      and red = ‹True,P,t ⊢1 e1',(h, xs) -ta E',(h', xs')
    from red have "τmove1 P h (e1' «bop» e2) = τmove1 P h e1'" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover from red have "call1 (e1' «bop» e2) = call1 e1'" by auto
    moreover from IH1[OF red] bsok
    obtain pc'' stk'' loc'' xcp'' where bisim: "P,e1,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and redo: "?exec ta e1 e1' E' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    from bisim 
    have "P,e1«bop»e2,h'  (E'«bop»e2, xs')  (stk'', loc'', pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1BinOp1)
    moreover { 
      assume "no_call2 e1 pc"
      hence "no_call2 (e1«bop»e2) pc  pc = length (compE2 e1)" by(auto simp add: no_call2_def) }
    ultimately show ?thesis using redo
      by(auto simp del: call1.simps calls1.simps split: if_split_asm split del: if_split)(blast intro: BinOp_τExecrI1 BinOp_τExectI1 exec_move_BinOpI1)+
  next
    case (Bin1OpRed2 E' v)
    note [simp] = e1' = Val v e' = Val v «bop» E'
      and red = ‹True,P,t ⊢1 e2,(h, xs) -ta E',(h', xs')
    from red have τ: "τmove1 P h (Val v «bop» e2) = τmove1 P h e2" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim1 have s: "xcp = None" "xs = loc"
      and exec1: "τExec_mover_a P t e1 h (stk, loc, pc, None) ([v], xs, length (compE2 e1), None)"
      by(auto dest: bisim1Val2D1)
    from exec1 have "τExec_mover_a P t (e1«bop»e2) h (stk, loc, pc, None) ([v], xs, length (compE2 e1), None)"
      by(rule BinOp_τExecrI1)
    moreover
    from IH2[OF red] bsok obtain pc'' stk'' loc'' xcp''
      where bisim': "P,e2,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and exec': "?exec ta e2 e2 E' h [] xs 0 None h' pc'' stk'' loc'' xcp''" by auto
    have "?exec ta (e1«bop»e2) (Val v«bop»e2) (Val v«bop»E') h ([] @ [v]) xs (length (compE2 e1) + 0) None h' (length (compE2 e1) + pc'') (stk'' @ [v]) loc'' xcp''"
    proof(cases "τmove1 P h (Val v «bop» e2)")
      case True
      with exec' τ have [simp]: "h = h'" and e: "sim_move e2 E' P t e2 h ([], xs, 0, None) (stk'', loc'', pc'', xcp'')" by auto
      from e have "sim_move (Val v«bop»e2) (Val v«bop»E') P t (e1 «bop» e2) h ([] @ [v], xs, length (compE2 e1) + 0, None) (stk'' @ [v], loc'', length (compE2 e1) + pc'', xcp'')"
        by(fastforce dest: BinOp_τExecrI2 BinOp_τExectI2)
      with True show ?thesis by auto
    next
      case False
      with exec' τ obtain pc' stk' loc' xcp'
        where e: "τExec_mover_a P t e2 h ([], xs, 0, None) (stk', loc', pc', xcp')"
        and e': "exec_move_a P t e2 h (stk', loc', pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'', loc'', pc'', xcp'')"
        and τ': "¬ τmove2 (compP2 P) h stk' e2 pc' xcp'" 
        and call: "call1 e2 = None  no_call2 e2 0  pc' = 0  stk' = []  loc' = xs  xcp' = None" by auto
      from e have "τExec_mover_a P t (e1 «bop» e2) h ([] @ [v], xs, length (compE2 e1) + 0, None) (stk' @ [v], loc', length (compE2 e1) + pc', xcp')" by(rule BinOp_τExecrI2)
      moreover from e' have "exec_move_a P t (e1 «bop» e2) h (stk' @ [v], loc', length (compE2 e1) + pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'' @ [v], loc'', length (compE2 e1) + pc'', xcp'')"
        by(rule exec_move_BinOpI2)
      moreover from e' have "pc' < length (compE2 e2)" by auto
      with τ' e' have "¬ τmove2 (compP2 P) h (stk' @ [v]) (e1 «bop» e2) (length (compE2 e1) + pc') xcp'"
        by(auto simp add: τinstr_stk_drop_exec_move τmove2_iff)
      moreover from red have "call1 (e1'«bop»e2) = call1 e2" by(auto)
      moreover have "no_call2 e2 0  no_call2 (e1«bop»e2) (length (compE2 e1))"
        by(auto simp add: no_call2_def)
      ultimately show ?thesis using False call
        by(auto simp del: split_paired_Ex call1.simps calls1.simps) blast
    qed
    moreover from bisim'
    have "P,e1«bop»e2,h'  (Val v«bop»E', xs')  ((stk'' @ [v]), loc'', length (compE2 e1) + pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1BinOp2)
    moreover from bisim1 have "pc  length (compE2 e1)  no_call2 (e1«bop»e2) pc"
      by(auto simp add: no_call2_def dest: bisim_Val_pc_not_Invoke bisim1_pc_length_compE2)
    ultimately show ?thesis using τ exec1 s
      apply(auto simp del: split_paired_Ex call1.simps calls1.simps split: if_split_asm split del: if_split)
      apply(blast intro: τExec_mover_trans|fastforce elim!: τExec_mover_trans simp del: split_paired_Ex call1.simps calls1.simps)+
      done
  next
    case (Red1BinOp v1 v2 v)
    note [simp] = e1' = Val v1 e2 = Val v2 ta = ε e' = Val v h' = h xs' = xs
      and binop = ‹binop bop v1 v2 = Inl v
    have τ: "τmove1 P h (Val v1 «bop» Val v2)" by(rule τmove1BinOp)
    from bisim1 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t e1 h (stk, loc, pc, xcp) ([v1], loc, length (compE2 e1), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1«bop»Val v2) h (stk, loc, pc, xcp) ([v1], loc, length (compE2 e1), None)"
      by-(rule BinOp_τExecrI1)
    also have "τmove2 (compP2 P) h [v1] (e1 «bop» Val v2) (length (compE2 e1) + 0) None"
      by(rule τmove2BinOp2)(rule τmove2Val)
    with binop have "τExec_mover_a P t (e1«bop»Val v2) h ([v1], loc, length (compE2 e1), None) ([v2, v1], loc, Suc (length (compE2 e1)), None)"
      by-(rule τExecr1step, auto intro!: exec_instr simp add: exec_move_def compP2_def)
    also (rtranclp_trans) from binop
    have "exec_meth_a (compP2 P) (compE2 (e1«bop»Val v2)) (compxE2 (e1«bop»Val v2) 0 0) t
                               h ([v2, v1], loc, Suc (length (compE2 e1)), None) ε
                               h ([v], loc, Suc (Suc (length (compE2 e1))), None)"
      by-(rule exec_instr, auto)
    moreover have "τmove2 (compP2 P) h [v2, v1] (e1«bop»Val v2) (Suc (length (compE2 e1))) None" by(simp add: τmove2_iff) 
    ultimately have "τExec_mover_a P t (e1 «bop» Val v2) h (stk, loc, pc, xcp) ([v], loc, Suc (Suc (length (compE2 e1))), None)"
      by(fastforce intro: rtranclp.rtrancl_into_rtrancl τexec_moveI simp add: exec_move_def compP2_def)
    moreover
    have "P, e1 «bop» Val v2, h  (Val v, loc)  ([v], loc, length (compE2 (e1 «bop» Val v2)), None)"
      by(rule bisim1Val2) simp
    ultimately show ?thesis using s τ by auto
  next
    case (Red1BinOpFail v1 v2 a)
    note [simp] = e1' = Val v1 e2 = Val v2 ta = ε e' = Throw a h' = h xs' = xs
      and binop = ‹binop bop v1 v2 = Inr a
    have τ: "τmove1 P h (Val v1 «bop» Val v2)" by(rule τmove1BinOp)
    from bisim1 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t e1 h (stk, loc, pc, xcp) ([v1], loc, length (compE2 e1), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1«bop»Val v2) h (stk, loc, pc, xcp) ([v1], loc, length (compE2 e1), None)"
      by-(rule BinOp_τExecrI1)
    also have "τmove2 (compP2 P) h [v1] (e1 «bop» Val v2) (length (compE2 e1) + 0) None"
      by(rule τmove2BinOp2)(rule τmove2Val)
    with binop have "τExec_mover_a P t (e1«bop»Val v2) h ([v1], loc, length (compE2 e1), None) ([v2, v1], loc, Suc (length (compE2 e1)), None)"
      by-(rule τExecr1step, auto intro!: exec_instr simp add: exec_move_def compP2_def)
    also (rtranclp_trans) from binop
    have "exec_meth_a (compP2 P) (compE2 (e1«bop»Val v2)) (compxE2 (e1«bop»Val v2) 0 0) t
                               h ([v2, v1], loc, Suc (length (compE2 e1)), None) ε
                               h ([v2, v1], loc, Suc (length (compE2 e1)), a)"
      by-(rule exec_instr, auto)
    moreover have "τmove2 (compP2 P) h [v2, v1] (e1«bop»Val v2) (Suc (length (compE2 e1))) None" by(simp add: τmove2_iff) 
    ultimately have "τExec_movet_a P t (e1 «bop» Val v2) h (stk, loc, pc, xcp) ([v2, v1], loc, Suc (length (compE2 e1)), a)"
      by(fastforce intro: rtranclp_into_tranclp1 τexec_moveI simp add: exec_move_def compP2_def)
    moreover 
    have "P, e1 «bop» Val v2, h  (Throw a, loc)  ([v2, v1], loc, length (compE2 e1) + length (compE2 (Val v2)), a)"
      by(rule bisim1BinOpThrow)
    ultimately show ?thesis using s τ by auto
  next
    case (Bin1OpThrow1 a)
    note [simp] = e1' = Throw a ta = ε e' = Throw a h' = h xs' = xs
    have τ: "τmove1 P h (Throw a «bop» e2)" by(rule τmove1BinOpThrow1)
    from bisim1 have "xcp = a  xcp = None" by(auto dest: bisim1_ThrowD)
    thus ?thesis
    proof
      assume [simp]: "xcp = a"
      with bisim1 have "P, e1«bop»e2, h  (Throw a, xs)  (stk, loc, pc, xcp)"
        by(auto intro: bisim1_bisims1.intros)
      thus ?thesis using τ by(fastforce)
    next
      assume [simp]: "xcp = None"
      with bisim1 obtain pc' where "τExec_mover_a P t e1 h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        and bisim': "P, e1, h  (Throw a, xs)  ([Addr a], loc, pc', a)"
        and [simp]: "xs = loc"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t (e1«bop»e2) h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        by-(rule BinOp_τExecrI1)
      moreover from bisim'
      have "P, e1«bop»e2, h  (Throw a, xs)  ([Addr a], loc, pc', a)"
        by(auto intro: bisim1_bisims1.bisim1BinOpThrow1)
      ultimately show ?thesis using τ by auto
    qed
  next
    case (Bin1OpThrow2 v a)
    note [simp] = e1' = Val v e2 = Throw a ta = ε e' = Throw a h' = h xs' = xs
    from bisim1 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t e1 h (stk, loc, pc, xcp) ([v], loc, length (compE2 e1), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1«bop»Throw a) h (stk, loc, pc, xcp) ([v], loc, length (compE2 e1), None)"
      by-(rule BinOp_τExecrI1)
    also have "τExec_mover_a P t (e1«bop»Throw a) h ([v], loc, length (compE2 e1), None) ([Addr a, v], loc, Suc (length (compE2 e1)), a)"
      by(rule τExecr2step)(auto simp add: exec_move_def exec_meth_instr τmove2_iff τmove1.simps τmoves1.simps)
    also (rtranclp_trans)
    have "P,e1«bop»Throw a,h  (Throw a, loc)  ([Addr a] @ [v], loc, (length (compE2 e1) + length (compE2 (addr a))), a)"
      by(rule bisim1BinOpThrow2[OF bisim1Throw2])
    moreover have "τmove1 P h (e1' «bop» e2)" by(auto intro: τmove1BinOpThrow2)
    ultimately show ?thesis using s by auto
  qed
next
  case (bisim1BinOp2 e2 n e2' xs stk loc pc xcp e1 bop v1)
  note IH2 = bisim1BinOp2.IH(2)
  note bisim1 = xs. P,e1,h  (e1, xs)  ([], xs, 0, None)
  note bisim2 = P,e2,h  (e2', xs)  (stk, loc, pc, xcp)
  note red = ‹True,P,t ⊢1 Val v1 «bop» e2',(h, xs) -ta e',(h', xs')
  note bsok = ‹bsok (e1 «bop» e2) n
  from red show ?case
  proof cases
    case (Bin1OpRed2 E')
    note [simp] = e' = Val v1 «bop» E'
      and red = ‹True,P,t ⊢1 e2',(h, xs) -ta E',(h', xs')
    from IH2[OF red] bsok obtain pc'' stk'' loc'' xcp''
      where bisim': "P,e2,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and exec': "?exec ta e2 e2' E' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    from red have τ: "τmove1 P h (Val v1 «bop» e2') = τmove1 P h e2'" by(auto simp add: τmove1.simps τmoves1.simps)
    have "no_call2 e2 pc  no_call2 (e1 «bop» e2) (length (compE2 e1) + pc)" by(auto simp add: no_call2_def)
    hence "?exec ta (e1«bop»e2) (Val v1«bop»e2') (Val v1«bop»E') h (stk @ [v1]) loc (length (compE2 e1) + pc) xcp h' (length (compE2 e1) + pc'') (stk'' @ [v1]) loc'' xcp''"
      using exec' τ
      apply(cases "τmove1 P h (Val v1 «bop» e2')")
      apply(auto)
      apply(blast intro: BinOp_τExecrI2 BinOp_τExectI2 exec_move_BinOpI2)
      apply(blast intro: BinOp_τExecrI2 BinOp_τExectI2 exec_move_BinOpI2)
      apply(rule exI conjI BinOp_τExecrI2 exec_move_BinOpI2|assumption)+
      apply(fastforce simp add: τinstr_stk_drop_exec_move τmove2_iff split: if_split_asm)
      apply(rule exI conjI BinOp_τExecrI2 exec_move_BinOpI2|assumption)+
      apply(fastforce simp add: τinstr_stk_drop_exec_move τmove2_iff split: if_split_asm)
      apply(rule exI conjI BinOp_τExecrI2 exec_move_BinOpI2 rtranclp.rtrancl_refl|assumption)+
      apply(fastforce simp add: τinstr_stk_drop_exec_move τmove2_iff split: if_split_asm)+
      done
    moreover from bisim'
    have "P,e1«bop»e2,h'  (Val v1«bop»E', xs')  (stk''@[v1], loc'', length (compE2 e1) + pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1BinOp2)
    ultimately show ?thesis using τ by auto blast+
  next
    case (Red1BinOp v2 v)
    note [simp] = e2' = Val v2 ta = ε e' = Val v h' = h xs' = xs
      and binop = ‹binop bop v1 v2 = Inl v
    have τ: "τmove1 P h (Val v1 «bop» Val v2)" by(rule τmove1BinOp)
    from bisim2 have s: "xcp = None" "xs = loc" 
      and "τExec_mover_a P t e2 h (stk, loc, pc, xcp) ([v2], loc, length (compE2 e2), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1«bop»e2) h (stk @ [v1], loc, length (compE2 e1) + pc, xcp) ([v2] @ [v1], loc, length (compE2 e1) + length (compE2 e2), None)"
      by-(rule BinOp_τExecrI2)
    moreover from binop
    have "exec_move_a P t (e1«bop»e2) h ([v2, v1], loc, length (compE2 e1) + length (compE2 e2), None) ε
                                  h ([v], loc, Suc (length (compE2 e1) + length (compE2 e2)), None)"
      unfolding exec_move_def by-(rule exec_instr, auto)
    moreover have "τmove2 (compP2 P) h [v2, v1] (e1«bop»e2) (length (compE2 e1) + length (compE2 e2)) None"
      by(simp add: τmove2_iff)
    ultimately have "τExec_mover_a P t (e1 «bop» e2) h (stk @ [v1], loc, length (compE2 e1) + pc, xcp) ([v], loc, Suc (length (compE2 e1) + length (compE2 e2)), None)"
      by(auto intro: rtranclp.rtrancl_into_rtrancl τexec_moveI simp add: compP2_def)
    moreover 
    have "P, e1 «bop» e2, h  (Val v, loc)  ([v], loc, length (compE2 (e1 «bop» e2)), None)"
      by(rule bisim1Val2) simp
    ultimately show ?thesis using s τ by(auto)
  next
    case (Red1BinOpFail v2 a)
    note [simp] = e2' = Val v2 ta = ε e' = Throw a h' = h xs' = xs
      and binop = ‹binop bop v1 v2 = Inr a
    have τ: "τmove1 P h (Val v1 «bop» Val v2)" by(rule τmove1BinOp)
    from bisim2 have s: "xcp = None" "xs = loc" 
      and "τExec_mover_a P t e2 h (stk, loc, pc, xcp) ([v2], loc, length (compE2 e2), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1«bop»e2) h (stk @ [v1], loc, length (compE2 e1) + pc, xcp) ([v2] @ [v1], loc, length (compE2 e1) + length (compE2 e2), None)"
      by-(rule BinOp_τExecrI2)
    moreover from binop
    have "exec_move_a P t (e1«bop»e2) h ([v2, v1], loc, length (compE2 e1) + length (compE2 e2), None) ε
                                  h ([v2, v1], loc, length (compE2 e1) + length (compE2 e2), a)"
      unfolding exec_move_def by-(rule exec_instr, auto)
    moreover have "τmove2 (compP2 P) h [v2, v1] (e1«bop»e2) (length (compE2 e1) + length (compE2 e2)) None"
      by(simp add: τmove2_iff)
    ultimately have "τExec_movet_a P t (e1 «bop» e2) h (stk @ [v1], loc, length (compE2 e1) + pc, xcp) ([v2, v1], loc, length (compE2 e1) + length (compE2 e2), a)"
      by(auto intro: rtranclp_into_tranclp1 τexec_moveI simp add: compP2_def)
    moreover
    have "P, e1 «bop» e2, h  (Throw a, loc)  ([v2, v1], loc, length (compE2 e1) + length (compE2 e2), a)"
      by(rule bisim1BinOpThrow)
    ultimately show ?thesis using s τ by(auto)
  next
    case (Bin1OpThrow2 a)
    note [simp] = e2' = Throw a ta = ε h' = h xs' = xs e' = Throw a
    have τ: "τmove1 P h (Val v1 «bop» Throw a)" by(rule τmove1BinOpThrow2)
    from bisim2 have "xcp = a  xcp = None" by(auto dest: bisim1_ThrowD)
    thus ?thesis
    proof
      assume [simp]: "xcp = a"
      with bisim2
      have "P, e1«bop»e2, h  (Throw a, xs)  (stk @ [v1], loc, length (compE2 e1) + pc, xcp)"
        by(auto intro: bisim1BinOpThrow2)
      thus ?thesis using τ by(fastforce)
    next
      assume [simp]: "xcp = None"
      with bisim2 obtain pc'
        where "τExec_mover_a P t e2 h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        and bisim': "P, e2, h  (Throw a, xs)  ([Addr a], loc, pc', a)" and [simp]: "xs = loc"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t (e1«bop»e2) h (stk @ [v1], loc, length (compE2 e1) + pc, None) ([Addr a] @ [v1], loc, length (compE2 e1) + pc', a)"
        by-(rule BinOp_τExecrI2)
      moreover from bisim'
      have "P, e1«bop»e2, h  (Throw a, xs)  ([Addr a]@[v1], loc, length (compE2 e1) + pc', a)"
        by-(rule bisim1BinOpThrow2, auto)
      ultimately show ?thesis using τ by auto
    qed
  qed auto
next
  case bisim1BinOpThrow1 thus ?case by fastforce
next
  case bisim1BinOpThrow2 thus ?case by fastforce
next
  case bisim1BinOpThrow thus ?case by fastforce
next
  case (bisim1LAss1 E n e xs stk loc pc xcp V)
  note IH = bisim1LAss1.IH(2)
  note bisim = P,E,h  (e, xs)  (stk, loc, pc, xcp)
  note red = ‹True,P,t ⊢1 V:=e,(h, xs) -ta e',(h', xs')
  note bsok = ‹bsok (V:=E) n
  from red show ?case
  proof cases
    case (LAss1Red ee')
    note [simp] = e' = V := ee'
      and red = ‹True,P,t ⊢1 e,(h, xs) -ta ee', (h', xs')
    from red have "τmove1 P h (V:=e) = τmove1 P h e" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover from red have "call1 (V:=e) = call1 e" by auto
    moreover from IH[OF red] bsok
    obtain pc'' stk'' loc'' xcp'' where bisim: "P,E,h'  (ee', xs')  (stk'', loc'', pc'', xcp'')"
      and redo: "?exec ta E e ee' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    from bisim
    have "P,V:=E,h'  (V:=ee', xs')  (stk'', loc'', pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1LAss1)
    moreover { 
      assume "no_call2 E pc"
      hence "no_call2 (V:=E) pc" by(auto simp add: no_call2_def) }
    ultimately show ?thesis using redo
      by(auto simp del: call1.simps calls1.simps split: if_split_asm split del: if_split)(blast intro: LAss_τExecrI LAss_τExectI exec_move_LAssI)+
  next
    case (Red1LAss v)
    note [simp] = e = Val v ta = ε e' = unit› h' = h xs' = xs[V := v]
      and V = V < length xs
    from bisim have s: "xcp = None" "xs = loc" by(auto dest: bisim_Val_loc_eq_xcp_None)
    from bisim have "τExec_mover_a P t E h (stk, loc, pc, xcp) ([v], loc, length (compE2 E), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (V:=E) h (stk, loc, pc, xcp) ([v], loc, length (compE2 E), None)"
      by(rule LAss_τExecrI)
    moreover have "exec_move_a P t (V:=E) h ([v], loc, length (compE2 E), None) ε h ([], loc[V := v], Suc (length (compE2 E)), None)"
      using V s by(auto intro: exec_instr simp add: exec_move_def)
    moreover have "τmove2 (compP2 P) h [v] (V := E) (length (compE2 E)) None" by(simp add: τmove2_iff)
    ultimately have "τExec_mover_a P t (V:=E) h (stk, loc, pc, xcp) ([], loc[V := v], Suc (length (compE2 E)), None)"
      by(auto intro: rtranclp.rtrancl_into_rtrancl τexec_moveI simp add: compP2_def)
    moreover have "τmove1 P h (V := Val v)" by(rule τmove1LAssRed)
    moreover have "P, V:=E, h  (unit, loc[V := v])  ([], loc[V := v], Suc (length (compE2 E)), None)"
      by(rule bisim1LAss2)
    ultimately show ?thesis using s by auto
  next
    case (LAss1Throw a)
    note [simp] = e = Throw a h' = h xs' = xs ta = ε e' = Throw a
    have τ: "τmove1 P h (V:=e)" by(auto intro: τmove1LAssThrow)
    from bisim have "xcp = a  xcp = None" by(auto dest: bisim1_ThrowD)
    thus ?thesis
    proof
      assume [simp]: "xcp = a"
      with bisim have "P, V:=E, h  (Throw a, xs)  (stk, loc, pc, xcp)" by(auto intro: bisim1LAssThrow)
      thus ?thesis using τ by(fastforce)
    next
      assume [simp]: "xcp = None"
      with bisim obtain pc'
        where "τExec_mover_a P t E h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        and bisim': "P, E, h  (Throw a, xs)  ([Addr a], loc, pc', a)" and [simp]: "xs = loc"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t (V:=E) h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        by-(rule LAss_τExecrI)
      moreover from bisim' have "P, V:=E, h  (Throw a, xs)  ([Addr a], loc, pc', a)"
        by-(rule bisim1LAssThrow, auto)
      ultimately show ?thesis using τ by auto
    qed
  qed
next
  case bisim1LAss2 thus ?case by fastforce
next
  case bisim1LAssThrow thus ?case by fastforce
next
  case (bisim1AAcc1 a n a' xs stk loc pc xcp i)
  note IH1 = bisim1AAcc1.IH(2)
  note IH2 = bisim1AAcc1.IH(4)
  note bisim1 = P,a,h  (a', xs)  (stk, loc, pc, xcp)
  note bisim2 = xs. P,i,h  (i, xs)  ([], xs, 0, None)
  note bsok = ‹bsok (ai) n
  from ‹True,P,t ⊢1 a'i,(h, xs) -ta e',(h', xs') show ?case
  proof cases
    case (AAcc1Red1 E')
    note [simp] = e' = E'i
      and red = ‹True,P,t ⊢1 a',(h, xs) -ta E',(h', xs')
    from red have "τmove1 P h (a'i) = τmove1 P h a'" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover from red have "call1 (a'i) = call1 a'" by auto
    moreover from IH1[OF red] bsok
    obtain pc'' stk'' loc'' xcp'' where bisim: "P,a,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and redo: "?exec ta a a' E' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    from bisim have "P,ai,h'  (E'i, xs')  (stk'', loc'', pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1AAcc1)
    moreover { 
      assume "no_call2 a pc"
      hence "no_call2 (ai) pc  pc = length (compE2 a)" by(auto simp add: no_call2_def) }
    ultimately show ?thesis using redo
      by(auto simp del: call1.simps calls1.simps split: if_split_asm split del: if_split)(blast intro: AAcc_τExecrI1 AAcc_τExectI1 exec_move_AAccI1)+
  next
    case (AAcc1Red2 E' v)
    note [simp] = a' = Val v e' = Val vE'
      and red = ‹True,P,t ⊢1 i,(h, xs) -ta E',(h', xs')
    from red have τ: "τmove1 P h (Val vi) = τmove1 P h i" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim1 have s: "xcp = None" "xs = loc"
      and exec1: "τExec_mover_a P t a h (stk, loc, pc, None) ([v], xs, length (compE2 a), None)"
      by(auto dest: bisim1Val2D1)
    from exec1 have "τExec_mover_a P t (ai) h (stk, loc, pc, None) ([v], xs, length (compE2 a), None)"
      by(rule AAcc_τExecrI1)
    moreover
    from IH2[OF red] bsok obtain pc'' stk'' loc'' xcp''
      where bisim': "P,i,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and exec': "?exec ta i i E' h [] xs 0 None h' pc'' stk'' loc'' xcp''" by auto
    have "?exec ta (ai) (Val vi) (Val vE') h ([] @ [v]) xs (length (compE2 a) + 0) None h' (length (compE2 a) + pc'') (stk'' @ [v]) loc'' xcp''"
    proof(cases "τmove1 P h (Val vi)")
      case True
      with exec' τ have [simp]: "h = h'" and e: "sim_move i E' P t i h ([], xs, 0, None) (stk'', loc'', pc'', xcp'')" by auto
      from e have "sim_move (ai) (aE') P t (ai) h ([] @ [v], xs, length (compE2 a) + 0, None) (stk'' @ [v], loc'', length (compE2 a) + pc'', xcp'')"
        by(fastforce dest: AAcc_τExecrI2 AAcc_τExectI2)
      with True show ?thesis by auto
    next
      case False
      with exec' τ obtain pc' stk' loc' xcp'
        where e: "τExec_mover_a P t i h ([], xs, 0, None) (stk', loc', pc', xcp')"
        and e': "exec_move_a P t i h (stk', loc', pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'', loc'', pc'', xcp'')"
        and τ': "¬ τmove2 (compP2 P) h stk' i pc' xcp'" 
        and call: "call1 i = None  no_call2 i 0  pc' = 0  stk' = []  loc' = xs  xcp' = None" by auto
      from e have "τExec_mover_a P t (ai) h ([] @ [v], xs, length (compE2 a) + 0, None) (stk' @ [v], loc', length (compE2 a) + pc', xcp')"
        by(rule AAcc_τExecrI2)
      moreover from e' have "exec_move_a P t (ai) h (stk' @ [v], loc', length (compE2 a) + pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'' @ [v], loc'', length (compE2 a) + pc'', xcp'')"
        by(rule exec_move_AAccI2)
      moreover from e' τ' have "¬ τmove2 (compP2 P) h (stk' @ [v]) (ai) (length (compE2 a) + pc') xcp'"
        by(auto simp add: τinstr_stk_drop_exec_move τmove2_iff)
      moreover have "call1 (a'i) = call1 i" by simp
      moreover have "no_call2 i 0  no_call2 (ai) (length (compE2 a))"
        by(auto simp add: no_call2_def)
      ultimately show ?thesis using False call
        by(auto simp del: split_paired_Ex call1.simps calls1.simps) blast
    qed
    moreover from bisim'
    have "P,ai,h'  (Val vE', xs')  ((stk'' @ [v]), loc'', length (compE2 a) + pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1AAcc2)
    moreover from bisim1 have "pc  length (compE2 a)  no_call2 (ai) pc"
      by(auto simp add: no_call2_def dest: bisim_Val_pc_not_Invoke bisim1_pc_length_compE2)
    ultimately show ?thesis using τ exec1 s
      apply(auto simp del: split_paired_Ex call1.simps calls1.simps split: if_split_asm split del: if_split)
      apply(blast intro: τExec_mover_trans|fastforce elim!: τExec_mover_trans simp del: split_paired_Ex call1.simps calls1.simps)+
      done
  next
    case (Red1AAcc A U len I v)
    hence [simp]: "a' = addr A" "e' = Val v" "i = Val (Intg I)" "h' = h" "xs' = xs"
                  "ta = ReadMem A (ACell (nat (sint I))) v"
      and hA: "typeof_addr h A = Array_type U len" and I: "0 <=s I" "sint I < int len"
      and read: "heap_read h A (ACell (nat (sint I))) v" by auto
    have τ: "¬ τmove1 P h (addr AVal (Intg I))" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim1 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t a h (stk, loc, pc, xcp) ([Addr A], loc, length (compE2 a), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (aVal (Intg I)) h (stk, loc, pc, xcp) ([Addr A], loc, length (compE2 a), None)"
      by-(rule AAcc_τExecrI1)
    also have "τmove2 (compP2 P) h [Addr A] (aVal (Intg I)) (length (compE2 a) + 0) None"
      by(rule τmove2AAcc2)(rule τmove2Val)
    hence "τExec_mover_a P t (aVal (Intg I)) h ([Addr A], loc, length (compE2 a), None) ([Intg I, Addr A], loc, Suc (length (compE2 a)), None)"
      by-(rule τExecr1step, auto intro!: exec_instr simp add: exec_move_def compP2_def)
    also (rtranclp_trans) from hA I read
    have "exec_move_a P t (aVal (Intg I)) h ([Intg I, Addr A], loc, Suc (length (compE2 a)), None) 
                                           ReadMem A (ACell (nat (sint I))) v
                                           h ([v], loc, Suc (Suc (length (compE2 a))), None)"
      unfolding exec_move_def by-(rule exec_instr, auto simp add: is_Ref_def)
    moreover have "τmove2 (compP2 P) h [Intg I, Addr A] (aVal (Intg I)) (Suc (length (compE2 a))) None  False"
      by(simp add: τmove2_iff)
    moreover
    have "P, aVal (Intg I), h  (Val v, loc)  ([v], loc, length (compE2 (aVal (Intg I))), None)"
      by(rule bisim1Val2) simp
    ultimately show ?thesis using s τ
      by(auto simp add: ta_upd_simps) blast
  next
    case (Red1AAccNull v)
    note [simp] = a' = null› i = Val v ta = ε e' = THROW NullPointer› h' = h xs' = xs
    from bisim1 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t a h (stk, loc, pc, xcp) ([Null], loc, length (compE2 a), None)"
      by(auto dest: bisim1Val2D1 intro: AAcc_τExecrI1)
    hence "τExec_mover_a P t (ai) h (stk, loc, pc, xcp) ([Null], loc, length (compE2 a), None)"
      by-(rule AAcc_τExecrI1)
    also from bisim2[of loc] have "τExec_mover_a P t i h ([], loc, 0, None) ([v], loc, length (compE2 i), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai) h ([] @ [Null], loc, length (compE2 a) + 0, None) ([v] @ [Null], loc, length (compE2 a) + length (compE2 i), None)"
      by(rule AAcc_τExecrI2)
    hence "τExec_mover_a P t (ai) h ([Null], loc, length (compE2 a), None) ([v, Null], loc, length (compE2 a) + length (compE2 i), None)" by simp
    also (rtranclp_trans) have "exec_move_a P t (ai) h ([v, Null], loc, length (compE2 a) + length (compE2 i), None) ε h ([v, Null], loc, length (compE2 a) + length (compE2 i), addr_of_sys_xcpt NullPointer)"
      unfolding exec_move_def by-(rule exec_instr, auto)
    moreover have "¬ τmove2 (compP2 P) h [v, Null] (ai) (length (compE2 a) + length (compE2 i)) None"
      by(simp add: τmove2_iff)
    moreover have "¬ τmove1 P h (a'i)" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover
    have "P,ai,h  (THROW NullPointer, xs)  ([v, Null], xs, length (compE2 a) + length (compE2 i), addr_of_sys_xcpt NullPointer)"
      by(rule bisim1_bisims1.bisim1AAccFail)
    ultimately show ?thesis using s by auto blast
  next
    case (Red1AAccBounds A U len I)
    hence [simp]: "a' = addr A" "e' = THROW ArrayIndexOutOfBounds" "i = Val (Intg I)"
      "ta = ε" "h' = h" "xs' = xs"
      and hA: "typeof_addr h A = Array_type U len" and I: "I <s 0  int len  sint I" by auto
    from bisim1 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t a h (stk, loc, pc, xcp) ([Addr A], loc, length (compE2 a), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai) h (stk, loc, pc, xcp) ([Addr A], loc, length (compE2 a), None)"
      by-(rule AAcc_τExecrI1)
    also from bisim2[of loc] have "τExec_mover_a P t i h ([], loc, 0, None) ([Intg I], loc, length (compE2 i), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai) h ([] @ [Addr A], loc, length (compE2 a) + 0, None) ([Intg I] @ [Addr A], loc, length (compE2 a) + length (compE2 i), None)"
      by(rule AAcc_τExecrI2)
    hence "τExec_mover_a P t (ai) h ([Addr A], loc, length (compE2 a), None) ([Intg I, Addr A], loc, length (compE2 a) + length (compE2 i), None)" by simp
    also (rtranclp_trans) from I hA
    have "exec_move_a P t (ai) h ([Intg I, Addr A], loc, length (compE2 a) + length (compE2 i), None) ε h ([Intg I, Addr A], loc, length (compE2 a) + length (compE2 i), addr_of_sys_xcpt ArrayIndexOutOfBounds)"
      unfolding exec_move_def by-(rule exec_instr, auto simp add: is_Ref_def)
    moreover have "¬ τmove2 (compP2 P) h [Intg I, Addr A] (ai) (length (compE2 a) + length (compE2 i)) None"
      by(simp add: τmove2_iff)
    moreover have "¬ τmove1 P h (a'i)" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover
    have "P,ai,h  (THROW ArrayIndexOutOfBounds, xs)  ([Intg I, Addr A], xs, length (compE2 a) + length (compE2 i), addr_of_sys_xcpt ArrayIndexOutOfBounds)"
      by(rule bisim1_bisims1.bisim1AAccFail)
    ultimately show ?thesis using s by auto blast
  next
    case (AAcc1Throw1 A)
    note [simp] = a' = Throw A ta = ε e' = Throw A h' = h xs' = xs
    have τ: "τmove1 P h (Throw Ai)" by(rule τmove1AAccThrow1)
    from bisim1 have "xcp = A  xcp = None" by(auto dest: bisim1_ThrowD)
    thus ?thesis
    proof
      assume [simp]: "xcp = A"
      with bisim1 have "P, ai, h  (Throw A, xs)  (stk, loc, pc, xcp)"
        by(auto intro: bisim1_bisims1.intros)
      thus ?thesis using τ by(fastforce)
    next
      assume [simp]: "xcp = None"
      with bisim1 obtain pc' where "τExec_mover_a P t a h (stk, loc, pc, None) ([Addr A], loc, pc', A)"
        and bisim': "P, a, h  (Throw A, xs)  ([Addr A], loc, pc', A)"
        and [simp]: "xs = loc"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t (ai) h (stk, loc, pc, None) ([Addr A], loc, pc', A)"
        by-(rule AAcc_τExecrI1)
      moreover from bisim'
      have "P, ai, h  (Throw A, xs)  ([Addr A], loc, pc', A)"
        by(auto intro: bisim1_bisims1.bisim1AAccThrow1)
      ultimately show ?thesis using τ by auto
    qed
  next
    case (AAcc1Throw2 v ad)
    note [simp] = a' = Val v i = Throw ad ta = ε e' = Throw ad h' = h xs' = xs
    from bisim1 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t a h (stk, loc, pc, xcp) ([v], loc, length (compE2 a), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (aThrow ad) h (stk, loc, pc, xcp) ([v], loc, length (compE2 a), None)"
      by-(rule AAcc_τExecrI1)
    also have "τExec_mover_a P t (aThrow ad) h ([v], loc, length (compE2 a), None) ([Addr ad, v], loc, Suc (length (compE2 a)), ad)"
      by(rule τExecr2step)(auto simp add: exec_move_def exec_meth_instr τmove2_iff τmove1.simps τmoves1.simps)
    also (rtranclp_trans)
    have "P,aThrow ad,h  (Throw ad, loc)  ([Addr ad] @ [v], loc, (length (compE2 a) + length (compE2 (addr ad))), ad)"
      by(rule bisim1AAccThrow2[OF bisim1Throw2])
    moreover have "τmove1 P h (a'Throw ad)" by(auto intro: τmove1AAccThrow2)
    ultimately show ?thesis using s by auto
  qed
next
  case (bisim1AAcc2 i n i' xs stk loc pc xcp a v1)
  note IH2 = bisim1AAcc2.IH(2)
  note bisim1 = xs. P,a,h  (a, xs)  ([], xs, 0, None)
  note bisim2 = P,i,h  (i', xs)  (stk, loc, pc, xcp)
  note red = ‹True,P,t ⊢1 Val v1i',(h, xs) -ta e',(h', xs')
  note bsok = ‹bsok (ai) n
  from red show ?case
  proof cases
    case (AAcc1Red2 E')
    note [simp] = e' = Val v1E'
      and red = ‹True,P,t ⊢1 i',(h, xs) -ta E',(h', xs')
    from IH2[OF red] bsok obtain pc'' stk'' loc'' xcp''
      where bisim': "P,i,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and exec': "?exec ta i i' E' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    from red have τ: "τmove1 P h (Val v1i') = τmove1 P h i'" by(auto simp add: τmove1.simps τmoves1.simps)
    have "no_call2 i pc  no_call2 (ai) (length (compE2 a) + pc)" by(auto simp add: no_call2_def)
    hence "?exec ta (ai) (Val v1i') (Val v1E') h (stk @ [v1]) loc (length (compE2 a) + pc) xcp h' (length (compE2 a) + pc'') (stk'' @ [v1]) loc'' xcp''"
      using exec' τ
      apply(cases "τmove1 P h (Val v1i')")
      apply(auto)
      apply(blast intro: AAcc_τExecrI2 AAcc_τExectI2 exec_move_AAccI2)
      apply(blast intro: AAcc_τExecrI2 AAcc_τExectI2 exec_move_AAccI2)
      apply(rule exI conjI AAcc_τExecrI2 exec_move_AAccI2|assumption)+
      apply(fastforce simp add: τinstr_stk_drop_exec_move τmove2_iff split: if_split_asm)
      apply(rule exI conjI AAcc_τExecrI2 exec_move_AAccI2|assumption)+
      apply(fastforce simp add: τinstr_stk_drop_exec_move τmove2_iff split: if_split_asm)
      apply(rule exI conjI AAcc_τExecrI2 exec_move_AAccI2 rtranclp.rtrancl_refl|assumption)+
      apply(fastforce simp add: τinstr_stk_drop_exec_move τmove2_iff split: if_split_asm)+
      done
    moreover from bisim'
    have "P,ai,h'  (Val v1E', xs')  (stk''@[v1], loc'', length (compE2 a) + pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1AAcc2)
    ultimately show ?thesis using τ by auto blast+
  next
    case (Red1AAcc A U len I v)
    hence [simp]: "v1 = Addr A" "e' = Val v" "i' = Val (Intg I)"
      "ta = ReadMem A (ACell (nat (sint I))) v" "h' = h" "xs' = xs"
      and hA: "typeof_addr h A = Array_type U len" and I: "0 <=s I" "sint I < int len"
      and read: "heap_read h A (ACell (nat (sint I))) v" by auto
    have τ: "¬ τmove1 P h (addr AVal (Intg I))" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim2 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t i h (stk, loc, pc, xcp) ([Intg I], loc, length (compE2 i), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai) h (stk @ [Addr A], loc, length (compE2 a) + pc, xcp) ([Intg I] @ [Addr A], loc, length (compE2 a) + length (compE2 i), None)"
      by-(rule AAcc_τExecrI2)
    moreover from hA I read
    have "exec_move_a P t (ai) h ([Intg I, Addr A], loc, length (compE2 a) + length (compE2 i), None)
                              ReadMem A (ACell (nat (sint I))) v
                              h ([v], loc, Suc (length (compE2 a) + length (compE2 i)), None)"
      unfolding exec_move_def by-(rule exec_instr, auto simp add: is_Ref_def)
    moreover have "τmove2 (compP2 P) h [Intg I, Addr A] (ai) (length (compE2 a) + length (compE2 i)) None  False"
      by(simp add: τmove2_iff)
    moreover
    have "P, ai, h  (Val v, loc)  ([v], loc, length (compE2 (ai)), None)"
      by(rule bisim1Val2) simp
    ultimately show ?thesis using s τ by(auto simp add: ta_upd_simps) blast
  next
    case (Red1AAccNull v)
    note [simp] = v1 = Null› i' = Val v ta = ε e' = THROW NullPointer› h' = h xs' = xs
    from bisim2 have [simp]: "xcp = None" "xs = loc"
      and "τExec_mover_a P t i h (stk, loc, pc, xcp) ([v], loc, length (compE2 i), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai) h (stk @ [Null], loc, length (compE2 a) + pc, xcp) ([v] @ [Null], loc, length (compE2 a) + length (compE2 i), None)"
      by-(rule AAcc_τExecrI2)
    moreover have "exec_move_a P t (ai) h ([v, Null], loc, length (compE2 a) + length (compE2 i), None) ε h ([v, Null], loc, length (compE2 a) + length (compE2 i), addr_of_sys_xcpt NullPointer)"
      unfolding exec_move_def by-(rule exec_instr, auto)
    moreover have "¬ τmove2 (compP2 P) h [v, Null] (ai) (length (compE2 a) + length (compE2 i)) None"
      by(simp add: τmove2_iff)
    moreover have "¬ τmove1 P h (nulli')" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover
    have "P,ai,h  (THROW NullPointer, xs)  ([v, Null], xs, length (compE2 a) + length (compE2 i), addr_of_sys_xcpt NullPointer)"
      by(rule bisim1_bisims1.bisim1AAccFail)
    ultimately show ?thesis by auto blast
  next
    case (Red1AAccBounds A U len I)
    hence [simp]: "v1 = Addr A" "e' = THROW ArrayIndexOutOfBounds" "i' = Val (Intg I)"
      "ta = ε" "h' = h" "xs' = xs"
      and hA: "typeof_addr h A = Array_type U len" and I: "I <s 0  int len  sint I" by auto
    from bisim2 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t i h (stk, loc, pc, xcp) ([Intg I], loc, length (compE2 i), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai) h (stk @ [Addr A], loc, length (compE2 a) + pc, xcp) ([Intg I] @ [Addr A], loc, length (compE2 a) + length (compE2 i), None)"
      by-(rule AAcc_τExecrI2)
    moreover from I hA
    have "exec_move_a P t (ai) h ([Intg I, Addr A], loc, length (compE2 a) + length (compE2 i), None) ε h ([Intg I, Addr A], loc, length (compE2 a) + length (compE2 i), addr_of_sys_xcpt ArrayIndexOutOfBounds)"
      unfolding exec_move_def by-(rule exec_instr, auto simp add: is_Ref_def)
    moreover have "¬ τmove2 (compP2 P) h [Intg I, Addr A] (ai) (length (compE2 a) + length (compE2 i)) None"
      by(simp add: τmove2_iff)
    moreover have "¬ τmove1 P h (addr Ai')" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover 
    have "P,ai,h  (THROW ArrayIndexOutOfBounds, xs)  ([Intg I, Addr A], xs, length (compE2 a) + length (compE2 i), addr_of_sys_xcpt ArrayIndexOutOfBounds)"
      by(rule bisim1_bisims1.bisim1AAccFail)
    ultimately show ?thesis using s by auto blast
  next
    case (AAcc1Throw2 A)
    note [simp] = i' = Throw A ta = ε e' = Throw A h' = h xs' = xs
    have τ: "τmove1 P h (Val v1Throw A)" by(rule τmove1AAccThrow2)
    from bisim2 have "xcp = A  xcp = None" by(auto dest: bisim1_ThrowD)
    thus ?thesis
    proof
      assume [simp]: "xcp = A"
      with bisim2
      have "P, ai, h  (Throw A, xs)  (stk @ [v1], loc, length (compE2 a) + pc, xcp)"
        by(auto intro: bisim1_bisims1.intros)
      thus ?thesis using τ by(auto)
    next
      assume [simp]: "xcp = None"
      with bisim2 obtain pc' where "τExec_mover_a P t i h (stk, loc, pc, None) ([Addr A], loc, pc', A)"
        and bisim': "P, i, h  (Throw A, xs)  ([Addr A], loc, pc', A)"
        and [simp]: "xs = loc"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t (ai) h (stk @ [v1], loc, length (compE2 a) + pc, None) ([Addr A] @ [v1], loc, length (compE2 a) + pc', A)"
        by-(rule AAcc_τExecrI2)
      moreover from bisim'
      have "P, ai, h  (Throw A, xs)  ([Addr A] @ [v1], loc, length (compE2 a) + pc', A)"
        by(rule bisim1_bisims1.bisim1AAccThrow2)
      ultimately show ?thesis using τ by auto
    qed
  qed auto
next
  case bisim1AAccThrow1 thus ?case by auto
next
  case bisim1AAccThrow2 thus ?case by auto
next
  case bisim1AAccFail thus ?case by auto
next
  case (bisim1AAss1 a n a' xs stk loc pc xcp i e)
  note IH1 = bisim1AAss1.IH(2)
  note IH2 = bisim1AAss1.IH(4)
  note IH3 = bisim1AAss1.IH(6)
  note bisim1 = P,a,h  (a', xs)  (stk, loc, pc, xcp)
  note bisim2 = xs. P,i,h  (i, xs)  ([], xs, 0, None)
  note bisim3 = xs. P,e,h  (e, xs)  ([], xs, 0, None)
  note bsok = ‹bsok (ai := e) n
  from ‹True,P,t ⊢1 a'i := e,(h, xs) -ta e',(h', xs') show ?case
  proof cases
    case (AAss1Red1 E')
    note [simp] = e' = E'i := e
      and red = ‹True,P,t ⊢1 a',(h, xs) -ta E',(h', xs')
    from red have "τmove1 P h (a'i := e) = τmove1 P h a'" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover from red have "call1 (a'i := e) = call1 a'" by auto
    moreover from IH1[OF red] bsok
    obtain pc'' stk'' loc'' xcp'' where bisim: "P,a,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and redo: "?exec ta a a' E' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    from bisim 
    have "P,ai := e,h'  (E'i := e, xs')  (stk'', loc'', pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1AAss1)
    moreover { 
      assume "no_call2 a pc"
      hence "no_call2 (ai := e) pc  pc = length (compE2 a)" by(auto simp add: no_call2_def) }
    ultimately show ?thesis using redo
      by(auto simp del: call1.simps calls1.simps split: if_split_asm split del: if_split)(blast intro: AAss_τExecrI1 AAss_τExectI1 exec_move_AAssI1)+
  next
    case (AAss1Red2 E' v)
    note [simp] = a' = Val v e' = Val vE' := e
      and red = ‹True,P,t ⊢1 i,(h, xs) -ta E',(h', xs')
    from red have τ: "τmove1 P h (Val vi := e) = τmove1 P h i" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim1 have s: "xcp = None" "xs = loc"
      and exec1: "τExec_mover_a P t a h (stk, loc, pc, None) ([v], xs, length (compE2 a), None)"
      by(auto dest: bisim1Val2D1)
    from exec1 have "τExec_mover_a P t (ai := e) h (stk, loc, pc, None) ([v], xs, length (compE2 a), None)"
      by(rule AAss_τExecrI1)
    moreover
    from IH2[OF red] bsok obtain pc'' stk'' loc'' xcp''
      where bisim': "P,i,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and exec': "?exec ta i i E' h [] xs 0 None h' pc'' stk'' loc'' xcp''" by auto
    have "?exec ta (ai := e) (Val vi := e) (Val vE' := e) h ([] @ [v]) xs (length (compE2 a) + 0) None h' (length (compE2 a) + pc'') (stk'' @ [v]) loc'' xcp''"
    proof(cases "τmove1 P h (Val vi := e)")
      case True
      with exec' τ have [simp]: "h = h'" and e: "sim_move i E' P t i h ([], xs, 0, None) (stk'', loc'', pc'', xcp'')" by auto
      from e have "sim_move (ai := e) (aE' := e) P t (ai := e) h ([] @ [v], xs, length (compE2 a) + 0, None) (stk'' @ [v], loc'', length (compE2 a) + pc'', xcp'')"
        by(fastforce dest: AAss_τExecrI2 AAss_τExectI2)
      with True show ?thesis by auto
    next
      case False
      with exec' τ obtain pc' stk' loc' xcp'
        where e: "τExec_mover_a P t i h ([], xs, 0, None) (stk', loc', pc', xcp')"
        and e': "exec_move_a P t i h (stk', loc', pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'', loc'', pc'', xcp'')"
        and τ': "¬ τmove2 (compP2 P) h stk' i pc' xcp'" 
        and call: "call1 i = None  no_call2 i 0  pc' = 0  stk' = []  loc' = xs  xcp' = None" by auto
      from e have "τExec_mover_a P t (ai := e) h ([] @ [v], xs, length (compE2 a) + 0, None) (stk' @ [v], loc', length (compE2 a) + pc', xcp')" by(rule AAss_τExecrI2)
      moreover from e' have "exec_move_a P t (ai := e) h (stk' @ [v], loc', length (compE2 a) + pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'' @ [v], loc'', length (compE2 a) + pc'', xcp'')"
        by(rule exec_move_AAssI2)
      moreover from e' have "pc' < length (compE2 i)" by(auto elim: exec_meth.cases)
      with τ' e' have "¬ τmove2 (compP2 P) h (stk' @ [v]) (ai := e) (length (compE2 a) + pc') xcp'"
        by(auto simp add: τinstr_stk_drop_exec_move τmove2_iff)
      moreover from red have "call1 (a'i := e) = call1 i" by auto
      moreover have "no_call2 i 0  no_call2 (ai := e) (length (compE2 a))"
        by(auto simp add: no_call2_def)
      ultimately show ?thesis using False call
        by(auto simp del: split_paired_Ex call1.simps calls1.simps) blast
    qed
    moreover from bisim'
    have "P,ai := e,h'  (Val vE' := e, xs')  ((stk'' @ [v]), loc'', length (compE2 a) + pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1AAss2)
    moreover from bisim1 have "pc  length (compE2 a)  no_call2 (ai := e) pc"
      by(auto simp add: no_call2_def dest: bisim_Val_pc_not_Invoke bisim1_pc_length_compE2)
    ultimately show ?thesis using τ exec1 s
      apply(auto simp del: split_paired_Ex call1.simps calls1.simps split: if_split_asm split del: if_split)
      apply(blast intro: τExec_mover_trans|fastforce elim!: τExec_mover_trans simp del: split_paired_Ex call1.simps calls1.simps)+
      done
  next
    case (AAss1Red3 E' v v')
    note [simp] = i = Val v' a' = Val v e' = Val vVal v' := E'
      and red = ‹True,P,t ⊢1 e,(h, xs) -ta E',(h', xs')
    from red have τ: "τmove1 P h (Val vVal v' := e) = τmove1 P h e" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim1 have s: "xcp = None" "xs = loc"
      and exec1: "τExec_mover_a P t a h (stk, loc, pc, None) ([] @ [v], xs, length (compE2 a) + 0, None)"
      by(auto dest: bisim1Val2D1)
    from exec1 have "τExec_mover_a P t (ai := e) h (stk, loc, pc, None) ([] @ [v], xs, length (compE2 a) + 0, None)"
      by(rule AAss_τExecrI1)
    also from bisim2[of xs] 
    have "τExec_mover_a P t i h ([], xs, 0, None) ([v'], xs, length (compE2 i), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai := e) h ([] @ [v], xs, length (compE2 a) + 0, None) ([v'] @ [v], xs, length (compE2 a) + length (compE2 i), None)"
      by(rule AAss_τExecrI2)
    also (rtranclp_trans) from IH3[OF red] bsok obtain pc'' stk'' loc'' xcp''
      where bisim': "P,e,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and exec': "?exec ta e e E' h [] xs 0 None h' pc'' stk'' loc'' xcp''" by auto
    have "?exec ta (ai := e) (Val vVal v' := e) (Val vVal v' := E') h ([] @ [v', v]) xs (length (compE2 a) + length (compE2 i) + 0) None h' (length (compE2 a) + length (compE2 i) + pc'') (stk'' @ [v', v]) loc'' xcp''"
    proof(cases "τmove1 P h (Val vVal v' := e)")
      case True
      with exec' τ have [simp]: "h = h'" and e: "sim_move e E' P t e h ([], xs, 0, None) (stk'', loc'', pc'', xcp'')" by auto
      from e have "sim_move (Val vVal v' := e) (Val vVal v' := E') P t (ai := e) h ([] @ [v', v], xs, length (compE2 a) + length (compE2 i) + 0, None) (stk'' @ [v', v], loc'', length (compE2 a) + length (compE2 i) + pc'', xcp'')"
        by(fastforce dest: AAss_τExectI3 AAss_τExecrI3 simp del: compE2.simps compEs2.simps)
      with True show ?thesis by auto
    next
      case False
      with exec' τ obtain pc' stk' loc' xcp'
        where e: "τExec_mover_a P t e h ([], xs, 0, None) (stk', loc', pc', xcp')"
        and e': "exec_move_a P t e h (stk', loc', pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'', loc'', pc'', xcp'')"
        and τ': "¬ τmove2 (compP2 P) h stk' e pc' xcp'" 
        and call: "call1 e = None  no_call2 e 0  pc' = 0  stk' = []  loc' = xs  xcp' = None" by auto
      from e have "τExec_mover_a P t (ai := e) h ([] @ [v', v], xs, length (compE2 a) + length (compE2 i) + 0, None) (stk' @ [v', v], loc', length (compE2 a) + length (compE2 i) + pc', xcp')" by(rule AAss_τExecrI3)
      moreover from e' have "exec_move_a P t (ai := e) h (stk' @ [v', v], loc', length (compE2 a) + length (compE2 i) + pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'' @ [v', v], loc'', length (compE2 a) + length (compE2 i) + pc'', xcp'')"
        by(rule exec_move_AAssI3)
      moreover from e' τ'
      have "¬ τmove2 (compP2 P) h (stk' @ [v', v]) (ai := e) (length (compE2 a) + length (compE2 i) + pc') xcp'"
        by(auto simp add: τinstr_stk_drop_exec_move τmove2_iff)
      moreover have "call1 (a'i := e) = call1 e" by simp
      moreover have "no_call2 e 0  no_call2 (ai := e) (length (compE2 a) + length (compE2 i))"
        by(auto simp add: no_call2_def)
      ultimately show ?thesis using False call
        by(auto simp del: split_paired_Ex call1.simps calls1.simps) blast
    qed
    moreover from bisim'
    have "P,ai := e,h'  (Val vVal v' := E', xs')  ((stk'' @ [v', v]),  loc'', length (compE2 a) + length (compE2 i) + pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1AAss3) 
    moreover from bisim1 have "pc  length (compE2 a) + length (compE2 i)  no_call2 (ai := e) pc"
      by(auto simp add: no_call2_def dest: bisim_Val_pc_not_Invoke bisim1_pc_length_compE2)
    ultimately show ?thesis using τ exec1 s
      apply(auto simp del: split_paired_Ex call1.simps calls1.simps split: if_split_asm split del: if_split)
      apply(blast intro: τExec_mover_trans|fastforce elim!: τExec_mover_trans simp del: split_paired_Ex call1.simps calls1.simps)+
      done
  next
    case (Red1AAss A U len I v U')
    hence [simp]: "a' = addr A" "e' = unit" "i = Val (Intg I)"
      "ta = WriteMem A (ACell (nat (sint I))) v" "xs' = xs" "e = Val v"
      and hA: "typeof_addr h A = Array_type U len" and I: "0 <=s I" "sint I < int len" 
      and v: "typeofh v = U'" "P  U'  U"
      and h': "heap_write h A (ACell (nat (sint I))) v h'" by auto
    have τ: "¬ τmove1 P h (AAss (addr A) (Val (Intg I)) (Val v))" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim1 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t a h (stk, loc, pc, xcp) ([] @ [Addr A], loc, length (compE2 a) + 0, None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai := e) h (stk, loc, pc, xcp) ([] @ [Addr A], loc, length (compE2 a) + 0, None)"
      by-(rule AAss_τExecrI1)
    also from bisim2[of loc]
    have "τExec_mover_a P t i h ([], loc, 0, None) ([Intg I], loc, length (compE2 i) + 0, None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai := e) h ([] @ [Addr A], loc, length (compE2 a) + 0, None) ([Intg I] @ [Addr A], loc, length (compE2 a) + (length (compE2 i) + 0), None)"
      by(rule AAss_τExecrI2)
    also (rtranclp_trans) have "[Intg I] @ [Addr A] = [] @ [Intg I, Addr A]" by simp
    also note add.assoc[symmetric]
    also from bisim3[of loc] have "τExec_mover_a P t e h ([], loc, 0, None) ([v], loc, length (compE2 e), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai := e) h ([] @ [Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + 0, None) ([v] @ [Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), None)"
      by(rule AAss_τExecrI3)
    also (rtranclp_trans) from hA I v h'
    have "exec_move_a P t (ai := e) h ([v, Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), None)
                                 WriteMem A (ACell (nat (sint I))) v
                                 h' ([], loc, Suc (length (compE2 a) + length (compE2 i) + length (compE2 e)), None)"
      unfolding exec_move_def by-(rule exec_instr, auto simp add: compP2_def is_Ref_def)
    moreover have "τmove2 (compP2 P) h [v, Intg I, Addr A] (ai := e) (length (compE2 a) + length (compE2 i) + length (compE2 e)) None  False"
      by(simp add: τmove2_iff)
    moreover
    have "P, ai := e, h'  (unit, loc)  ([], loc, Suc (length (compE2 a) + length (compE2 i) + length (compE2 e)), None)"
      by(rule bisim1_bisims1.bisim1AAss4)
    ultimately show ?thesis using s τ by(auto simp add: ta_upd_simps) blast
  next
    case (Red1AAssNull v v')
    note [simp] = a' = null› e' = THROW NullPointer› i = Val v xs' = xs ta = ε h' = h e = Val v'
    have τ: "¬ τmove1 P h (AAss null (Val v) (Val v'))" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim1 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t a h (stk, loc, pc, xcp) ([] @ [Null], loc, length (compE2 a) + 0, None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai := e) h (stk, loc, pc, xcp) ([] @ [Null], loc, length (compE2 a) + 0, None)"
      by-(rule AAss_τExecrI1)
    also from bisim2[of loc] have "τExec_mover_a P t i h ([], loc, 0, None) ([v], loc, length (compE2 i) + 0, None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai := e) h ([] @ [Null], loc, length (compE2 a) + 0, None) ([v] @ [Null], loc, length (compE2 a) + (length (compE2 i) + 0), None)"
      by(rule AAss_τExecrI2)
    also (rtranclp_trans) have "[v] @ [Null] = [] @ [v, Null]" by simp
    also note add.assoc[symmetric]
    also from bisim3[of loc] have "τExec_mover_a P t e h ([], loc, 0, None) ([v'], loc, length (compE2 e), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai := e) h ([] @ [v, Null], loc, length (compE2 a) + length (compE2 i) + 0, None) ([v'] @ [v, Null], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), None)"
      by(rule AAss_τExecrI3)
    also (rtranclp_trans)
    have "exec_move_a P t (ai := e) h ([v', v, Null], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), None) ε
                                 h ([v', v, Null], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), addr_of_sys_xcpt NullPointer)"
      unfolding exec_move_def by-(rule exec_instr, auto simp add: is_Ref_def)
    moreover have "τmove2 (compP2 P) h [v', v, Null] (ai := e) (length (compE2 a) + length (compE2 i) + length (compE2 e)) None  False"
      by(simp add: τmove2_iff)
    moreover
    have "P, ai := e, h'  (THROW NullPointer, loc)  ([v', v, Null], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), addr_of_sys_xcpt NullPointer)"
      by(rule bisim1_bisims1.bisim1AAssFail)
    ultimately show ?thesis using s τ by auto blast
  next
    case (Red1AAssBounds A U len I v)
    hence [simp]: "a' = addr A" "e' = THROW ArrayIndexOutOfBounds" "i = Val (Intg I)" "xs' = xs" "ta = ε" "h' = h" "e = Val v"
      and hA: "typeof_addr h A = Array_type U len" and I: "I <s 0  int len  sint I" by auto
    have τ: "¬ τmove1 P h (AAss (addr A) i e)" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim1 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t a h (stk, loc, pc, xcp) ([] @ [Addr A], loc, length (compE2 a) + 0, None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai := e) h (stk, loc, pc, xcp) ([] @ [Addr A], loc, length (compE2 a) + 0, None)"
      by-(rule AAss_τExecrI1)
    also from bisim2[of loc] 
    have "τExec_mover_a P t i h ([], loc, 0, None) ([Intg I], loc, length (compE2 i) + 0, None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai := e) h ([] @ [Addr A], loc, length (compE2 a) + 0, None) ([Intg I] @ [Addr A], loc, length (compE2 a) + (length (compE2 i) + 0), None)"
      by(rule AAss_τExecrI2)
    also (rtranclp_trans) have "[Intg I] @ [Addr A] = [] @ [Intg I, Addr A]" by simp
    also note add.assoc[symmetric]
    also from bisim3[of loc]
    have "τExec_mover_a P t e h ([], loc, 0, None) ([v], loc, length (compE2 e), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai := e) h ([] @ [Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + 0, None) ([v] @ [Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), None)"
      by(rule AAss_τExecrI3)
    also (rtranclp_trans) from hA I
    have "exec_move_a P t (ai := e) h ([v, Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), None) ε
                                 h ([v, Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), addr_of_sys_xcpt ArrayIndexOutOfBounds)"
      unfolding exec_move_def by-(rule exec_instr, auto simp add: is_Ref_def)
    moreover have "τmove2 (compP2 P) h [v, Intg I, Addr A] (ai := e) (length (compE2 a) + length (compE2 i) + length (compE2 e)) None  False"
      by(simp add: τmove2_iff)
    moreover
    have "P, ai := e, h'  (THROW ArrayIndexOutOfBounds, loc)  ([v, Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), addr_of_sys_xcpt ArrayIndexOutOfBounds)"
      by(rule bisim1_bisims1.bisim1AAssFail)
    ultimately show ?thesis using s τ by auto blast
  next
    case (Red1AAssStore A U len I v U')
    hence [simp]: "a' = addr A" "e' = THROW ArrayStore" "i = Val (Intg I)" "xs' = xs" "ta = ε" "h' = h" "e = Val v"
      and hA: "typeof_addr h A = Array_type U len" and I: "0 <=s I" "sint I < int len" 
      and U: "¬ P  U'  U" "typeofh v = U'" by auto
    have τ: "¬ τmove1 P h (AAss (addr A) i e)" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim1 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t a h (stk, loc, pc, xcp) ([] @ [Addr A], loc, length (compE2 a) + 0, None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai := e) h (stk, loc, pc, xcp) ([] @ [Addr A], loc, length (compE2 a) + 0, None)"
      by-(rule AAss_τExecrI1)
    also from bisim2[of loc] 
    have "τExec_mover_a P t i h ([], loc, 0, None) ([Intg I], loc, length (compE2 i) + 0, None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai := e) h ([] @ [Addr A], loc, length (compE2 a) + 0, None) ([Intg I] @ [Addr A], loc, length (compE2 a) + (length (compE2 i) + 0), None)"
      by(rule AAss_τExecrI2)
    also (rtranclp_trans) have "[Intg I] @ [Addr A] = [] @ [Intg I, Addr A]" by simp
    also note add.assoc[symmetric]
    also from bisim3[of loc] 
    have "τExec_mover_a P t e h ([], loc, 0, None) ([v], loc, length (compE2 e), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai := e) h ([] @ [Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + 0, None) ([v] @ [Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), None)"
      by(rule AAss_τExecrI3)
    also (rtranclp_trans) from hA I U
    have "exec_move_a P t (ai := e) h ([v, Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), None) ε
                                  h ([v, Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), addr_of_sys_xcpt ArrayStore)"
      unfolding exec_move_def by-(rule exec_instr, auto simp add: is_Ref_def compP2_def)
    moreover have "τmove2 (compP2 P) h [v, Intg I, Addr A] (ai := e) (length (compE2 a) + length (compE2 i) + length (compE2 e)) None  False"
      by(simp add: τmove2_iff)
    moreover
    have "P, ai := e, h'  (THROW ArrayStore, loc)  ([v, Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), addr_of_sys_xcpt ArrayStore)"
      by(rule bisim1_bisims1.bisim1AAssFail)
    ultimately show ?thesis using s τ by auto blast
  next
    case (AAss1Throw1 A)
    hence [simp]: "a' = Throw A" "ta = ε" "e' = Throw A" "h' = h" "xs' = xs" by auto
    have τ: "τmove1 P h (Throw Ai := e)" by(rule τmove1AAssThrow1)
    from bisim1 have "xcp = A  xcp = None" by(auto dest: bisim1_ThrowD)
    thus ?thesis
    proof
      assume [simp]: "xcp = A"
      with bisim1 have "P, ai := e, h  (Throw A, xs)  (stk, loc, pc, xcp)"
        by(auto intro: bisim1_bisims1.intros)
      thus ?thesis using τ by(fastforce)
    next
      assume [simp]: "xcp = None"
      with bisim1 obtain pc' where "τExec_mover_a P t a h (stk, loc, pc, None) ([Addr A], loc, pc', A)"
        and bisim': "P, a, h  (Throw A, xs)  ([Addr A], loc, pc', A)"
        and [simp]: "xs = loc"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t (ai := e) h (stk, loc, pc, None) ([Addr A], loc, pc', A)"
        by-(rule AAss_τExecrI1)
      moreover from bisim' 
      have "P, ai := e, h  (Throw A, xs)  ([Addr A], loc, pc', A)"
        by(auto intro: bisim1_bisims1.bisim1AAssThrow1)
      ultimately show ?thesis using τ by auto
    qed
  next
    case (AAss1Throw2 v ad)
    note [simp] = a' = Val v i = Throw ad ta = ε e' = Throw ad h' = h xs' = xs
    from bisim1 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t a h (stk, loc, pc, xcp) ([v], loc, length (compE2 a), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (aThrow ad := e) h (stk, loc, pc, xcp) ([v], loc, length (compE2 a), None)"
      by-(rule AAss_τExecrI1)
    also have "τExec_mover_a P t (aThrow ad:=e) h ([v], loc, length (compE2 a), None) ([Addr ad, v], loc, Suc (length (compE2 a)), ad)"
      by(rule τExecr2step)(auto simp add: exec_move_def exec_meth_instr τmove2_iff τmove1.simps τmoves1.simps)
    also (rtranclp_trans)
    have "P,aThrow ad:=e,h  (Throw ad, loc)  ([Addr ad] @ [v], loc, (length (compE2 a) + length (compE2 (addr ad))), ad)"
      by(rule bisim1AAssThrow2[OF bisim1Throw2])
    moreover have "τmove1 P h (a'Throw ad:=e)" by(auto intro: τmove1AAssThrow2)
    ultimately show ?thesis using s by auto
  next
    case (AAss1Throw3 va vi ad)
    note [simp] = a' = Val va i = Val vi e = Throw ad ta = ε e' = Throw ad h' = h xs' = xs
    from bisim1 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t a h (stk, loc, pc, xcp) ([va], loc, length (compE2 a), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai := Throw ad) h (stk, loc, pc, xcp) ([va], loc, length (compE2 a), None)"
      by-(rule AAss_τExecrI1)
    also from bisim2[of loc] have "τExec_mover_a P t i h ([], loc, 0, None) ([vi], loc, length (compE2 i), None)"
      by(auto dest: bisim1Val2D1)
    from AAss_τExecrI2[OF this, of a e va]
    have "τExec_mover_a P t (ai := Throw ad) h ([va], loc, length (compE2 a), None) ([vi, va], loc, length (compE2 a) + length (compE2 i), None)" by simp
    also (rtranclp_trans)
    have "τExec_mover_a P t (ai:=Throw ad) h ([vi, va], loc, length (compE2 a) + length (compE2 i), None) ([Addr ad, vi, va], loc, Suc (length (compE2 a) + length (compE2 i)), ad)"
      by(rule τExecr2step)(auto simp add: exec_move_def exec_meth_instr τmove2_iff τmove1.simps τmoves1.simps)
    also (rtranclp_trans)
    have "P,ai:=Throw ad,h  (Throw ad, loc)  ([Addr ad] @ [vi, va], loc, (length (compE2 a) + length (compE2 i) + length (compE2 (addr ad))), ad)"
      by(rule bisim1AAssThrow3[OF bisim1Throw2])
    moreover have "τmove1 P h (AAss a' (Val vi) (Throw ad))" by(auto intro: τmove1AAssThrow3)
    ultimately show ?thesis using s by auto
  qed
next
  case (bisim1AAss2 i n i' xs stk loc pc xcp a e v1)
  note IH2 = bisim1AAss2.IH(2)
  note IH3 = bisim1AAss2.IH(6)
  note bisim2 = P,i,h  (i', xs)  (stk, loc, pc, xcp)
  note bisim1 = xs. P,a,h  (a, xs)  ([], xs, 0, None)
  note bisim3 = xs. P,e,h  (e, xs)  ([], xs, 0, None)
  note bsok = ‹bsok (ai := e) n
  from ‹True,P,t ⊢1 Val v1i' := e,(h, xs) -ta e',(h', xs') show ?case
  proof cases
    case (AAss1Red2 E')
    note [simp] = e' = Val v1E' := e
      and red = ‹True,P,t ⊢1 i',(h, xs) -ta E',(h', xs')
    from red have τ: "τmove1 P h (Val v1i' := e) = τmove1 P h i'" by(auto simp add: τmove1.simps τmoves1.simps)
    from IH2[OF red] bsok obtain pc'' stk'' loc'' xcp''
      where bisim': "P,i,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and exec': "?exec ta i i' E' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    have "?exec ta (ai := e) (Val v1i' := e) (Val v1E' := e) h (stk @ [v1]) loc (length (compE2 a) + pc) xcp h' (length (compE2 a) + pc'') (stk'' @ [v1]) loc'' xcp''"
    proof(cases "τmove1 P h (Val v1i' := e)")
      case True
      with exec' τ have [simp]: "h = h'" and e: "sim_move i' E' P t i h (stk, loc, pc, xcp) (stk'', loc'', pc'', xcp'')" by auto
      from e have "sim_move (Val v1i' := e) (Val v1E' := e) P t (ai := e) h (stk @ [v1], loc, length (compE2 a) + pc, xcp) (stk'' @ [v1], loc'', length (compE2 a) + pc'', xcp'')"
        by(fastforce dest: AAss_τExecrI2 AAss_τExectI2 simp del: compE2.simps compEs2.simps)
      with True show ?thesis by auto
    next
      case False
      with exec' τ obtain pc' stk' loc' xcp'
        where e: "τExec_mover_a P t i h (stk, loc, pc, xcp) (stk', loc', pc', xcp')"
        and e': "exec_move_a P t i h (stk', loc', pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'', loc'', pc'', xcp'')"
        and τ': "¬ τmove2 (compP2 P) h stk' i pc' xcp'" 
        and call: "call1 i' = None  no_call2 i pc  pc' = pc  stk' = stk  loc' = loc  xcp' = xcp" by auto
      from e have "τExec_mover_a P t (ai := e) h (stk @ [v1], loc, length (compE2 a) + pc, xcp) (stk' @ [v1], loc', length (compE2 a) + pc', xcp')" by(rule AAss_τExecrI2)
      moreover from e' have "exec_move_a P t (ai := e) h (stk' @ [v1], loc', length (compE2 a) + pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'' @ [v1], loc'', length (compE2 a) + pc'', xcp'')"
        by(rule exec_move_AAssI2)
      moreover from e' have "pc' < length (compE2 i)" by(auto elim: exec_meth.cases)
      with τ' e' have "¬ τmove2 (compP2 P) h (stk' @ [v1]) (ai := e) (length (compE2 a) + pc') xcp'"
        by(auto simp add: τinstr_stk_drop_exec_move τmove2_iff)
      moreover from red have "call1 (Val v1i' := e) = call1 i'" by auto
      moreover have "no_call2 i pc  no_call2 (ai := e) (length (compE2 a) + pc)"
        by(auto simp add: no_call2_def)
      ultimately show ?thesis using False call by(auto simp del: split_paired_Ex call1.simps calls1.simps) 
    qed
    moreover from bisim'
    have "P,ai := e,h'  (Val v1E' := e, xs')  ((stk'' @ [v1]),  loc'', length (compE2 a) + pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1AAss2)
    ultimately show ?thesis
      apply(auto simp del: split_paired_Ex call1.simps calls1.simps split: if_split_asm split del: if_split)
      apply(blast intro: τExec_mover_trans)+
      done
  next
    case (AAss1Red3 E' v')
    note [simp] = i' = Val v' e' = Val v1Val v' := E'
      and red = ‹True,P,t ⊢1 e,(h, xs) -ta E',(h', xs')
    from red have τ: "τmove1 P h (Val v1Val v' := e) = τmove1 P h e"
      by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim2 have s: "xcp = None" "xs = loc"
      and exec1: "τExec_mover_a P t i h (stk, loc, pc, xcp) ([v'], xs, length (compE2 i), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai := e) h (stk @ [v1], loc, length (compE2 a) + pc, xcp) ([v'] @ [v1], xs, length (compE2 a) + length (compE2 i), None)"
      by-(rule AAss_τExecrI2)
    moreover from IH3[OF red] bsok obtain pc'' stk'' loc'' xcp''
      where bisim': "P,e,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and exec': "?exec ta e e E' h [] xs 0 None h' pc'' stk'' loc'' xcp''" by auto
    have "?exec ta (ai := e) (Val v1Val v' := e) (Val v1Val v' := E') h ([] @ [v', v1]) xs (length (compE2 a) + length (compE2 i) + 0) None h' (length (compE2 a) + length (compE2 i) + pc'') (stk'' @ [v', v1]) loc'' xcp''"
    proof(cases "τmove1 P h (Val v1Val v' := e)")
      case True
      with exec' τ have [simp]: "h = h'"
        and e: "sim_move e E' P t e h ([], xs, 0, None) (stk'', loc'', pc'', xcp'')" by auto
      from e have "sim_move (Val v1Val v' := e) (Val v1Val v' := E') P t (ai := e) h ([] @ [v', v1], xs, length (compE2 a) + length (compE2 i) + 0, None) (stk'' @ [v', v1], loc'', length (compE2 a) + length (compE2 i) + pc'', xcp'')"
        by(fastforce dest: AAss_τExectI3 AAss_τExecrI3 simp del: compE2.simps compEs2.simps)
      with True show ?thesis by auto
    next
      case False
      with exec' τ obtain pc' stk' loc' xcp'
        where e: "τExec_mover_a P t e h ([], xs, 0, None) (stk', loc', pc', xcp')"
        and e': "exec_move_a P t e h (stk', loc', pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'', loc'', pc'', xcp'')"
        and τ': "¬ τmove2 (compP2 P) h stk' e pc' xcp'" 
        and call: "call1 e = None  no_call2 e 0  pc' = 0  stk' = []  loc' = xs  xcp' = None" by auto
      from e have "τExec_mover_a P t (ai := e) h ([] @ [v', v1], xs, length (compE2 a) + length (compE2 i) + 0, None) (stk' @ [v', v1], loc', length (compE2 a) + length (compE2 i) + pc', xcp')" by(rule AAss_τExecrI3)
      moreover from e' have "exec_move_a P t (ai := e) h (stk' @ [v', v1], loc', length (compE2 a) + length (compE2 i) + pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'' @ [v', v1], loc'', length (compE2 a) + length (compE2 i) + pc'', xcp'')"
        by(rule exec_move_AAssI3)
      moreover from e' τ' have "¬ τmove2 (compP2 P) h (stk' @ [v', v1]) (ai := e) (length (compE2 a) + length (compE2 i) + pc') xcp'"
        by(auto simp add: τinstr_stk_drop_exec_move τmove2_iff)
      moreover from red have "call1 (Val v1Val v' := e) = call1 e" by auto
      moreover have "no_call2 e 0  no_call2 (ai := e) (length (compE2 a) + length (compE2 i))"
        by(auto simp add: no_call2_def)
      ultimately show ?thesis using False call by(auto simp del: split_paired_Ex call1.simps calls1.simps) blast 
    qed
    moreover from bisim'
    have "P,ai := e,h'  (Val v1Val v' := E', xs')  ((stk'' @ [v', v1]),  loc'', length (compE2 a) + length (compE2 i) + pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1AAss3)
    moreover from bisim2 have "pc  length (compE2 i)  no_call2 (ai := e) (length (compE2 a) + pc)"
      by(auto simp add: no_call2_def dest: bisim_Val_pc_not_Invoke bisim1_pc_length_compE2)
    ultimately show ?thesis using τ exec1 s
      apply(auto simp del: split_paired_Ex call1.simps calls1.simps split: if_split_asm split del: if_split)
      apply(blast intro: τExec_mover_trans|fastforce elim!: τExec_mover_trans simp del: split_paired_Ex call1.simps calls1.simps)+
      done
  next
    case (Red1AAss A U len I v U')
    hence [simp]: "v1 = Addr A" "e' = unit" "i' = Val (Intg I)"
      "ta = WriteMem A (ACell (nat (sint I))) v" "xs' = xs" "e = Val v"
      and hA: "typeof_addr h A = Array_type U len" and I: "0 <=s I" "sint I < int len"
      and v: "typeofh v = U'" "P  U'  U"
      and h': "heap_write h A (ACell (nat (sint I))) v h'" by auto
    have τ: "¬ τmove1 P h (AAss (addr A) (Val (Intg I)) (Val v))" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim2 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t i h (stk, loc, pc, xcp) ([Intg I], loc, length (compE2 i), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai := e) h (stk @ [Addr A], loc, length (compE2 a) + pc, xcp) ([Intg I] @ [Addr A], loc, length (compE2 a) + length (compE2 i), None)"
      by-(rule AAss_τExecrI2)
    hence "τExec_mover_a P t (ai := e) h (stk @ [Addr A], loc, length (compE2 a) + pc, xcp) ([] @ [Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + 0, None)" by simp
    also from bisim3[of loc] have "τExec_mover_a P t e h ([], loc, 0, None) ([v], loc, length (compE2 e), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai := e) h ([] @ [Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + 0, None) ([v] @ [Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), None)"
      by(rule AAss_τExecrI3)
    also (rtranclp_trans) from hA I v h'
    have "exec_move_a P t (ai := e) h ([v, Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), None)
                                 WriteMem A (ACell (nat (sint I))) v
                                 h' ([], loc, Suc (length (compE2 a) + length (compE2 i) + length (compE2 e)), None)"
      unfolding exec_move_def by-(rule exec_instr, auto simp add: compP2_def is_Ref_def)
    moreover have "τmove2 (compP2 P) h [v, Intg I, Addr A] (ai := e) (length (compE2 a) + length (compE2 i) + length (compE2 e)) None  False"
      by(simp add: τmove2_iff)
    moreover
    have "P, ai := e, h'  (unit, loc)  ([], loc, Suc (length (compE2 a) + length (compE2 i) + length (compE2 e)), None)"
      by(rule bisim1_bisims1.bisim1AAss4)
    ultimately show ?thesis using s τ by(auto simp add: ta_upd_simps) blast
  next
    case (Red1AAssNull v v')
    note [simp] = v1 = Null› e' = THROW NullPointer› i' = Val v xs' = xs ta = ε h' = h e = Val v'
    have τ: "¬ τmove1 P h (AAss null (Val v) (Val v'))" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim2 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t i h (stk, loc, pc, xcp) ([v], loc, length (compE2 i), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai := e) h (stk @ [Null], loc, length (compE2 a) + pc, xcp) ([v] @ [Null], loc, length (compE2 a) + length (compE2 i), None)"
      by-(rule AAss_τExecrI2)
    hence "τExec_mover_a P t (ai := e) h (stk @ [Null], loc, length (compE2 a) + pc, xcp) ([] @ [v, Null], loc, length (compE2 a) + length (compE2 i) + 0, None)" by simp
    also from bisim3[of loc] have "τExec_mover_a P t e h ([], loc, 0, None) ([v'], loc, length (compE2 e), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai := e) h ([] @ [v, Null], loc, length (compE2 a) + length (compE2 i) + 0, None) ([v'] @ [v, Null], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), None)"
      by(rule AAss_τExecrI3)
    also (rtranclp_trans)
    have "exec_move_a P t (ai := e) h ([v', v, Null], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), None) ε
                                 h ([v', v, Null], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), addr_of_sys_xcpt NullPointer)"
      unfolding exec_move_def by-(rule exec_instr, auto simp add: is_Ref_def)
    moreover have "τmove2 (compP2 P) h [v', v, Null] (ai := e) (length (compE2 a) + length (compE2 i) + length (compE2 e)) None  False"
      by(simp add: τmove2_iff)
    moreover
    have "P, ai := e, h'  (THROW NullPointer, loc)  ([v', v, Null], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), addr_of_sys_xcpt NullPointer)"
      by(rule bisim1_bisims1.bisim1AAssFail)
    ultimately show ?thesis using s τ by auto blast
  next
    case (Red1AAssBounds A U len I v)
    hence [simp]: "v1 = Addr A" "e' = THROW ArrayIndexOutOfBounds" "i' = Val (Intg I)" "xs' = xs" "ta = ε" "h' = h" "e = Val v"
      and hA: "typeof_addr h A = Array_type U len" and I: "I <s 0  int len  sint I" by auto
    have τ: "¬ τmove1 P h (addr Ai' := e)" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim2 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t i h (stk, loc, pc, xcp) ([Intg I], loc, length (compE2 i), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai := e) h (stk @ [Addr A], loc, length (compE2 a) + pc, xcp) ([Intg I] @ [Addr A], loc, length (compE2 a) + length (compE2 i), None)"
      by-(rule AAss_τExecrI2)
    hence "τExec_mover_a P t (ai := e) h (stk @ [Addr A], loc, length (compE2 a) + pc, xcp) ([] @ [Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + 0, None)" by simp
    also from bisim3[of loc] have "τExec_mover_a P t e h ([], loc, 0, None) ([v], loc, length (compE2 e), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai := e) h ([] @ [Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + 0, None) ([v] @ [Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), None)"
      by(rule AAss_τExecrI3)
    also (rtranclp_trans) from hA I
    have "exec_move_a P t (ai := e) h ([v, Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), None) ε
                                 h ([v, Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), addr_of_sys_xcpt ArrayIndexOutOfBounds)"
      unfolding exec_move_def by-(rule exec_instr, auto simp add: is_Ref_def)
    moreover have "τmove2 (compP2 P) h [v, Intg I, Addr A] (ai := e) (length (compE2 a) + length (compE2 i) + length (compE2 e)) None  False"
      by(simp add: τmove2_iff)
    moreover
    have "P, ai := e, h'  (THROW ArrayIndexOutOfBounds, loc)  ([v, Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), addr_of_sys_xcpt ArrayIndexOutOfBounds)"
      by(rule bisim1_bisims1.bisim1AAssFail)
    ultimately show ?thesis using s τ by auto blast
  next
    case (Red1AAssStore A U len I v U')
    hence [simp]: "v1 = Addr A" "e' = THROW ArrayStore" "i' = Val (Intg I)" "xs' = xs" "ta = ε" "h' = h" "e = Val v"
      and hA: "typeof_addr h A = Array_type U len" and I: "0 <=s I" "sint I < int len" 
      and U: "¬ P  U'  U" "typeofh v = U'" by auto
    have τ: "¬ τmove1 P h (addr Ai' := e)" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim2 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t i h (stk, loc, pc, xcp) ([Intg I], loc, length (compE2 i), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai := e) h (stk @ [Addr A], loc, length (compE2 a) + pc, xcp) ([Intg I] @ [Addr A], loc, length (compE2 a) + length (compE2 i), None)"
      by-(rule AAss_τExecrI2)
    hence "τExec_mover_a P t (ai := e) h (stk @ [Addr A], loc, length (compE2 a) + pc, xcp) ([] @ [Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + 0, None)" by simp
    also from bisim3[of loc] 
    have "τExec_mover_a P t e h ([], loc, 0, None) ([v], loc, length (compE2 e), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai := e) h ([] @ [Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + 0, None) ([v] @ [Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), None)"
      by(rule AAss_τExecrI3)
    also (rtranclp_trans) from hA I U
    have "exec_move_a P t (ai := e) h ([v, Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), None) ε
                                 h ([v, Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), addr_of_sys_xcpt ArrayStore)"
      unfolding exec_move_def by- (rule exec_instr, auto simp add: is_Ref_def compP2_def)
    moreover have "τmove2 (compP2 P) h [v, Intg I, Addr A] (ai := e) (length (compE2 a) + length (compE2 i) + length (compE2 e)) None  False"
      by(simp add: τmove2_iff)
    moreover
    have "P, ai := e, h'  (THROW ArrayStore, loc)  ([v, Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), addr_of_sys_xcpt ArrayStore)"
      by(rule bisim1_bisims1.bisim1AAssFail)
    ultimately show ?thesis using s τ by auto fast
  next
    case (AAss1Throw2 A)
    note [simp] = i' = Throw A ta = ε e' = Throw A h' = h xs' = xs
    have τ: "τmove1 P h (Val v1Throw A := e)" by(rule τmove1AAssThrow2)
    from bisim2 have "xcp = A  xcp = None" by(auto dest: bisim1_ThrowD)
    thus ?thesis
    proof
      assume [simp]: "xcp = A"
      with bisim2
      have "P, ai := e, h  (Throw A, xs)  (stk @ [v1], loc, length (compE2 a) + pc, xcp)"
        by(auto intro: bisim1_bisims1.intros)
      thus ?thesis using τ by(fastforce)
    next
      assume [simp]: "xcp = None"
      with bisim2 obtain pc' where "τExec_mover_a P t i h (stk, loc, pc, None) ([Addr A], loc, pc', A)"
        and bisim': "P, i, h  (Throw A, xs)  ([Addr A], loc, pc', A)"
        and [simp]: "xs = loc"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t (ai := e) h (stk @ [v1], loc, length (compE2 a) + pc, None) ([Addr A] @ [v1], loc, length (compE2 a) + pc', A)"
        by-(rule AAss_τExecrI2)
      moreover from bisim'
      have "P, ai := e, h  (Throw A, xs)  ([Addr A] @ [v1], loc, length (compE2 a) +  pc', A)"
        by(rule bisim1_bisims1.bisim1AAssThrow2)
      ultimately show ?thesis using τ by auto
    qed
  next
    case (AAss1Throw3 vi ad)
    note [simp] = i' = Val vi e = Throw ad ta = ε e' = Throw ad h' = h xs' = xs
    from bisim2 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t i h (stk, loc, pc, xcp) ([vi], loc, length (compE2 i), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai := Throw ad) h (stk @ [v1], loc, length (compE2 a) + pc, xcp) ([vi] @ [v1], loc, length (compE2 a) + length (compE2 i), None)"
      by-(rule AAss_τExecrI2)
    also have "τExec_mover_a P t (ai:=Throw ad) h ([vi] @ [v1], loc, length (compE2 a) + length (compE2 i), None) ([Addr ad, vi, v1], loc, Suc (length (compE2 a) + length (compE2 i)), ad)"
      by(rule τExecr2step)(auto simp add: exec_move_def exec_meth_instr τmove2_iff τmove1.simps τmoves1.simps)
    also (rtranclp_trans)
    have "P,ai:=Throw ad,h  (Throw ad, loc)  ([Addr ad] @ [vi, v1], loc, (length (compE2 a) + length (compE2 i) + length (compE2 (addr ad))), ad)"
      by(rule bisim1AAssThrow3[OF bisim1Throw2])
    moreover have "τmove1 P h (AAss (Val v1) (Val vi) (Throw ad))" by(auto intro: τmove1AAssThrow3)
    ultimately show ?thesis using s by auto
  qed auto
next
  case (bisim1AAss3 e n ee xs stk loc pc xcp a i v v')
  note IH3 = bisim1AAss3.IH(2)
  note bisim3 = P,e,h  (ee, xs)  (stk, loc, pc, xcp)
  note bsok = ‹bsok (ai := e) n
  from ‹True,P,t ⊢1 Val vVal v' := ee,(h, xs) -ta e',(h', xs') show ?case
  proof cases
    case (AAss1Red3 E')
    note [simp] = e' = Val vVal v' := E'
      and red = ‹True,P,t ⊢1 ee,(h, xs) -ta E',(h', xs')
    from red have τ: "τmove1 P h (Val vVal v' := ee) = τmove1 P h ee" by(auto simp add: τmove1.simps τmoves1.simps)
    from IH3[OF red] bsok obtain pc'' stk'' loc'' xcp''
      where bisim': "P,e,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and exec': "?exec ta e ee E' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    have "no_call2 e pc  no_call2 (ai := e) (length (compE2 a) + length (compE2 i) +  pc)" 
      by(auto simp add: no_call2_def)
    hence "?exec ta (ai := e) (Val vVal v' := ee) (Val vVal v' := E') h (stk @ [v', v]) loc (length (compE2 a) + length (compE2 i) + pc) xcp h' (length (compE2 a) + length (compE2 i) + pc'') (stk'' @ [v', v]) loc'' xcp''"
      using exec' τ
      apply(cases "τmove1 P h (Val vVal v' := ee)")
      apply(auto)
      apply(blast intro: AAss_τExecrI3 AAss_τExectI3 exec_move_AAssI3)
      apply(blast intro: AAss_τExecrI3 AAss_τExectI3 exec_move_AAssI3)
      apply(rule exI conjI AAss_τExecrI3 exec_move_AAssI3|assumption)+
      apply(fastforce simp add: τinstr_stk_drop_exec_move τmove2_iff split: if_split_asm)
      apply(rule exI conjI AAss_τExecrI3 exec_move_AAssI3|assumption)+
      apply(fastforce simp add: τinstr_stk_drop_exec_move τmove2_iff split: if_split_asm)
      apply(rule exI conjI AAss_τExecrI3 exec_move_AAssI3 rtranclp.rtrancl_refl|assumption)+
      apply(fastforce simp add: τinstr_stk_drop_exec_move τmove2_iff split: if_split_asm)+
      done
    moreover from bisim'
    have "P,ai := e,h'  (Val vVal v' := E', xs')  (stk''@[v',v], loc'', length (compE2 a) + length (compE2 i) + pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1AAss3)
    ultimately show ?thesis using τ by auto blast+
  next
    case (Red1AAss A U len I V U')
    hence [simp]: "v = Addr A" "e' = unit" "v' = Intg I" "xs' = xs" "ee = Val V"
      "ta = WriteMem A (ACell (nat (sint I))) V"
      and hA: "typeof_addr h A = Array_type U len" and I: "0 <=s I" "sint I < int len" 
      and v: "typeofh V = U'" "P  U'  U"
      and h': "heap_write h A (ACell (nat (sint I))) V h'" by auto
    have τ: "¬ τmove1 P h (AAss (addr A) (Val (Intg I)) (Val V))" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim3 have s: "xcp = None" "xs = loc"
      and exec1: "τExec_mover_a P t e h (stk, loc, pc, xcp) ([V], loc, length (compE2 e), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai := e) h (stk @ [Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + pc, xcp) ([V] @ [Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), None)"
      by-(rule AAss_τExecrI3)
    moreover from hA I v h'
    have "exec_move_a P t (ai := e) h ([V, Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), None) 
                                 WriteMem A (ACell (nat (sint I))) V
                                 h' ([], loc, Suc (length (compE2 a) + length (compE2 i) + length (compE2 e)), None)"
     unfolding exec_move_def by-(rule exec_instr, auto simp add: compP2_def is_Ref_def)
    moreover have "τmove2 (compP2 P) h [V, Intg I, Addr A] (ai := e) (length (compE2 a) + length (compE2 i) + length (compE2 e)) None  False"
      by(simp add: τmove2_iff)
    moreover 
    have "P, ai := e, h'  (unit, loc)  ([], loc, Suc (length (compE2 a) + length (compE2 i) + length (compE2 e)), None)"
      by(rule bisim1_bisims1.bisim1AAss4)
    ultimately show ?thesis using s τ by(auto simp add: ta_upd_simps) blast
  next
    case (Red1AAssNull V')
    note [simp] = v = Null› e' = THROW NullPointer› xs' = xs ta = ε h' = h ee = Val V'
    have τ: "¬ τmove1 P h (AAss null (Val v') (Val V'))" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim3 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t e h (stk, loc, pc, xcp) ([V'], loc, length (compE2 e), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai := e) h (stk @ [v', Null], loc, length (compE2 a) + length (compE2 i) + pc, xcp) ([V'] @ [v', Null], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), None)"
      by-(rule AAss_τExecrI3)
    moreover
    have "exec_move_a P t (ai := e) h ([V', v', Null], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), None) ε
                                 h ([V', v', Null], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), addr_of_sys_xcpt NullPointer)"
      unfolding exec_move_def by-(rule exec_instr, auto simp add: is_Ref_def)
    moreover have "τmove2 (compP2 P) h [V', v', Null] (ai := e) (length (compE2 a) + length (compE2 i) + length (compE2 e)) None  False"
      by(simp add: τmove2_iff)
    moreover
    have "P, ai := e, h'  (THROW NullPointer, loc)  ([V', v', Null], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), addr_of_sys_xcpt NullPointer)"
      by(rule bisim1_bisims1.bisim1AAssFail)
    ultimately show ?thesis using s τ by auto blast
  next
    case (Red1AAssBounds A U len I V)
    hence [simp]: "v = Addr A" "e' = THROW ArrayIndexOutOfBounds" "v' = Intg I" "xs' = xs" "ta = ε" "h' = h" "ee = Val V"
      and hA: "typeof_addr h A = Array_type U len" and I: "I <s 0  int len  sint I" by auto
    have τ: "¬ τmove1 P h (addr AVal (Intg I) := ee)" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim3 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t e h (stk, loc, pc, xcp) ([V], loc, length (compE2 e), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai := e) h (stk @ [Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + pc, xcp) ([V] @ [Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), None)"
      by-(rule AAss_τExecrI3)
    moreover from hA I
    have "exec_move_a P t (ai := e) h ([V, Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), None) ε
                                 h ([V, Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), addr_of_sys_xcpt ArrayIndexOutOfBounds)"
      unfolding exec_move_def by-(rule exec_instr, auto simp add: is_Ref_def)
    moreover have "τmove2 (compP2 P) h [V, Intg I, Addr A] (ai := e) (length (compE2 a) + length (compE2 i) + length (compE2 e)) None  False"
      by(simp add: τmove2_iff)
    moreover
    have "P, ai := e, h'  (THROW ArrayIndexOutOfBounds, loc)  ([V, Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), addr_of_sys_xcpt ArrayIndexOutOfBounds)"
      by(rule bisim1_bisims1.bisim1AAssFail)
    ultimately show ?thesis using s τ by auto blast
  next 
    case (Red1AAssStore A U len I V U')
    hence [simp]: "v = Addr A" "e' = THROW ArrayStore" "v' = Intg I" "xs' = xs" "ta = ε" "h' = h" "ee = Val V"
      and hA: "typeof_addr h A = Array_type U len" and I: "0 <=s I" "sint I < int len" 
      and U: "¬ P  U'  U" "typeofh V = U'" by auto
    have τ: "¬ τmove1 P h (addr AVal (Intg I) := ee)" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim3 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t e h (stk, loc, pc, xcp) ([V], loc, length (compE2 e), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (ai := e) h (stk @ [Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + pc, xcp) ([V] @ [Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), None)"
      by-(rule AAss_τExecrI3)
    moreover from hA I U
    have "exec_move_a P t (ai := e) h ([V, Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), None) ε
                                 h ([V, Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), addr_of_sys_xcpt ArrayStore)"
      unfolding exec_move_def by-(rule exec_instr, auto simp add: is_Ref_def compP2_def)
    moreover have "τmove2 (compP2 P) h [V, Intg I, Addr A] (ai := e) (length (compE2 a) + length (compE2 i) + length (compE2 e)) None  False"
      by(simp add: τmove2_iff)
    moreover
    have "P, ai := e, h'  (THROW ArrayStore, loc)  ([V, Intg I, Addr A], loc, length (compE2 a) + length (compE2 i) + length (compE2 e), addr_of_sys_xcpt ArrayStore)"
      by(rule bisim1_bisims1.bisim1AAssFail)
    ultimately show ?thesis using s τ by auto blast
  next
    case (AAss1Throw3 A)
    note [simp] = ee = Throw A ta = ε e' = Throw A h' = h xs' = xs
    have τ: "τmove1 P h (AAss (Val v) (Val v') (Throw A))" by(rule τmove1AAssThrow3)
    from bisim3 have "xcp = A  xcp = None" by(auto dest: bisim1_ThrowD)
    thus ?thesis
    proof
      assume [simp]: "xcp = A"
      with bisim3
      have "P, ai := e, h  (Throw A, xs)  (stk @ [v', v], loc, length (compE2 a) + length (compE2 i) + pc, xcp)"
        by(auto intro: bisim1_bisims1.intros)
      thus ?thesis using τ by(fastforce)
    next
      assume [simp]: "xcp = None"
      with bisim3 obtain pc' where "τExec_mover_a P t e h (stk, loc, pc, None) ([Addr A], loc, pc', A)"
        and bisim': "P, e, h  (Throw A, xs)  ([Addr A], loc, pc', A)"
        and [simp]: "xs = loc"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t (ai := e) h (stk @ [v', v], loc, length (compE2 a) + length (compE2 i) + pc, None) ([Addr A] @ [v', v], loc, length (compE2 a) + length (compE2 i) + pc', A)"
        by-(rule AAss_τExecrI3)
      moreover from bisim'
      have "P, ai := e, h  (Throw A, xs)  ([Addr A] @ [v', v], loc, length (compE2 a) +  length (compE2 i) + pc', A)"
        by(rule bisim1_bisims1.bisim1AAssThrow3)
      ultimately show ?thesis using τ by auto
    qed
  qed auto
next
  case bisim1AAssThrow1 thus ?case by auto
next
  case bisim1AAssThrow2 thus ?case by auto
next
  case bisim1AAssThrow3 thus ?case by auto
next
  case bisim1AAssFail thus ?case by auto
next
  case bisim1AAss4 thus ?case by auto
next
  case (bisim1ALength a n a' xs stk loc pc xcp)
  note IH = bisim1ALength.IH(2)
  note bisim = P,a,h  (a', xs)  (stk, loc, pc, xcp)
  note red = ‹True,P,t ⊢1 a'∙length,(h, xs) -ta e',(h', xs')
  note bsok = ‹bsok (a∙length) n
  from red show ?case
  proof cases
    case (ALength1Red ee')
    note [simp] = e' = ee'∙length
      and red = ‹True,P,t ⊢1 a',(h, xs) -ta ee', (h', xs')
    from red have "τmove1 P h (a'∙length) = τmove1 P h a'" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover have "call1 (a'∙length) = call1 a'" by auto
    moreover from IH[OF red] bsok
    obtain pc'' stk'' loc'' xcp'' where bisim: "P,a,h'  (ee', xs')  (stk'', loc'', pc'', xcp'')"
      and redo: "?exec ta a a' ee' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    from bisim have "P,a∙length,h'  (ee'∙length, xs')  (stk'', loc'', pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1ALength)
    moreover { 
      assume "no_call2 a pc"
      hence "no_call2 (a∙length) pc" by(auto simp add: no_call2_def) }
    ultimately show ?thesis using redo
      by(auto simp del: call1.simps calls1.simps split: if_split_asm split del: if_split)(blast intro: ALength_τExecrI ALength_τExectI exec_move_ALengthI)+
  next
    case (Red1ALength A U len)
    hence [simp]: "a' = addr A" "ta = ε" "e' = Val (Intg (word_of_int (int len)))"
      "h' = h" "xs' = xs"
      and hA: "typeof_addr h A = Array_type U len" by auto
    from bisim have s: "xcp = None" "xs = loc" by(auto dest: bisim_Val_loc_eq_xcp_None)
    from bisim have "τExec_mover_a P t a h (stk, loc, pc, xcp) ([Addr A], loc, length (compE2 a), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (a∙length) h (stk, loc, pc, xcp) ([Addr A], loc, length (compE2 a), None)"
      by(rule ALength_τExecrI)
    moreover from hA
    have "exec_move_a P t (a∙length) h ([Addr A], loc, length (compE2 a), None) ε h' ([Intg (word_of_int (int len))], loc, Suc (length (compE2 a)), None)"
      by(auto intro!: exec_instr simp add: is_Ref_def exec_move_def)
    moreover have "τmove2 (compP2 P) h [Addr A] (a∙length) (length (compE2 a)) None  False" by(simp add: τmove2_iff)
    moreover have "¬ τmove1 P h (addr A∙length)" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover
    have "P, a∙length, h'  (Val (Intg (word_of_int (int len))), loc)  ([Intg (word_of_int (int len))], loc, length (compE2 (a∙length)), None)"
      by(rule bisim1Val2) simp
    ultimately show ?thesis using s by(auto) blast
  next
    case Red1ALengthNull
    note [simp] = a' = null› e' = THROW NullPointer› h' = h xs' = xs ta = ε
    have "¬ τmove1 P h (null∙length)" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover from bisim have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t a h (stk, loc, pc, xcp) ([Null], loc, length (compE2 a), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (a∙length) h (stk, loc, pc, xcp) ([Null], loc, length (compE2 a), None)"
      by-(rule ALength_τExecrI)
    moreover have "exec_move_a P t (a∙length) h ([Null], loc, length (compE2 a), None) ε h ([Null], loc, length (compE2 a), addr_of_sys_xcpt NullPointer)"
      unfolding exec_move_def by -(rule exec_instr, auto simp add: is_Ref_def)
    moreover have "τmove2 (compP2 P) h [Null] (a∙length) (length (compE2 a)) None  False" by(simp add: τmove2_iff)
    moreover 
    have "P,a∙length,h  (THROW NullPointer, loc)  ([Null], loc, length (compE2 a), addr_of_sys_xcpt NullPointer)"
      by(auto intro!: bisim1_bisims1.bisim1ALengthNull)
    ultimately show ?thesis using s by auto blast
  next
    case (ALength1Throw A)
    note [simp] = a' = Throw A h' = h xs' = xs ta = ε e' = Throw A
    have τ: "τmove1 P h (Throw A∙length)" by(auto intro: τmove1ALengthThrow)
    from bisim have "xcp = A  xcp = None" by(auto dest: bisim1_ThrowD)
    thus ?thesis
    proof
      assume [simp]: "xcp = A"
      with bisim have "P,a∙length, h  (Throw A, xs)  (stk, loc, pc, xcp)"
        by(auto intro: bisim1_bisims1.bisim1ALengthThrow)
      thus ?thesis using τ by(fastforce)
    next
      assume [simp]: "xcp = None"
      with bisim obtain pc'
        where "τExec_mover_a P t a h (stk, loc, pc, None) ([Addr A], loc, pc', A)"
        and bisim': "P, a, h  (Throw A, xs)  ([Addr A], loc, pc', A)" and [simp]: "xs = loc"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t (a∙length) h (stk, loc, pc, None) ([Addr A], loc, pc', A)"
        by-(rule ALength_τExecrI)
      moreover from bisim' have "P, a∙length, h  (Throw A, xs)  ([Addr A], loc, pc', A)"
        by(rule bisim1_bisims1.bisim1ALengthThrow)
      ultimately show ?thesis using τ by auto
    qed
  qed
next
  case bisim1ALengthThrow thus ?case by auto
next
  case bisim1ALengthNull thus ?case by auto
next
  case (bisim1FAcc E n e xs stk loc pc xcp F D)
  note IH = bisim1FAcc.IH(2)
  note bisim = P,E,h  (e, xs)  (stk, loc, pc, xcp)
  note red = ‹True,P,t ⊢1 eF{D},(h, xs) -ta e',(h', xs')
  note bsok = ‹bsok (EF{D}) n
  from red show ?case
  proof cases
    case (FAcc1Red ee')
    note [simp] = e' = ee'F{D}
      and red = ‹True,P,t ⊢1 e,(h, xs) -ta ee', (h', xs')
    from red have "τmove1 P h (eF{D}) = τmove1 P h e" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover have "call1 (eF{D}) = call1 e" by auto
    moreover from IH[OF red] bsok
    obtain pc'' stk'' loc'' xcp'' where bisim: "P,E,h'  (ee', xs')  (stk'', loc'', pc'', xcp'')"
      and redo: "?exec ta E e ee' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    from bisim
    have "P,EF{D},h'  (ee'F{D}, xs')  (stk'', loc'', pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1FAcc)
    moreover { 
      assume "no_call2 E pc"
      hence "no_call2 (EF{D}) pc" by(auto simp add: no_call2_def) }
    ultimately show ?thesis using redo
      by(auto simp del: call1.simps calls1.simps split: if_split_asm split del: if_split)(blast intro: FAcc_τExecrI FAcc_τExectI exec_move_FAccI)+
  next
    case (Red1FAcc a v)
    hence [simp]: "e = addr a" "ta = ReadMem a (CField D F) v" "e' = Val v" "h' = h" "xs' = xs"
      and read: "heap_read h a (CField D F) v" by auto
    from bisim have s: "xcp = None" "xs = loc" by(auto dest: bisim_Val_loc_eq_xcp_None)
    from bisim have "τExec_mover_a P t E h (stk, loc, pc, xcp) ([Addr a], loc, length (compE2 E), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (EF{D}) h (stk, loc, pc, xcp) ([Addr a], loc, length (compE2 E), None)"
      by(rule FAcc_τExecrI)
    moreover from read 
    have "exec_move_a P t (EF{D}) h ([Addr a], loc, length (compE2 E), None) 
                     ReadMem a (CField D F) v h' ([v], loc, Suc (length (compE2 E)), None)"
      unfolding exec_move_def by(auto intro!: exec_instr)
    moreover have "τmove2 (compP2 P) h [Addr a] (EF{D}) (length (compE2 E)) None  False" by(simp add: τmove2_iff)
    moreover have "¬ τmove1 P h (addr aF{D})" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover
    have "P, EF{D}, h'  (Val v, loc)  ([v], loc, length (compE2 (EF{D})), None)"
      by(rule bisim1Val2) simp
    ultimately show ?thesis using s by(auto simp add: ta_upd_simps) blast
  next
    case Red1FAccNull
    note [simp] = e = null› e' = THROW NullPointer› h' = h xs' = xs ta = ε
    have "¬ τmove1 P h (nullF{D})" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover from bisim have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t E h (stk, loc, pc, xcp) ([Null], loc, length (compE2 E), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (EF{D}) h (stk, loc, pc, xcp) ([Null], loc, length (compE2 E), None)"
      by-(rule FAcc_τExecrI)
    moreover
    have "exec_move_a P t (EF{D}) h ([Null], loc, length (compE2 E), None) ε h ([Null], loc, length (compE2 E), addr_of_sys_xcpt NullPointer)"
      unfolding exec_move_def by -(rule exec_instr, auto simp add: compP2_def dest: sees_field_idemp)
    moreover have "τmove2 (compP2 P) h [Null] (EF{D}) (length (compE2 E)) None  False" by(simp add: τmove2_iff)
    moreover
    have "P,EF{D},h  (THROW NullPointer, loc)  ([Null], loc, length (compE2 E), addr_of_sys_xcpt NullPointer)"
      by(rule bisim1_bisims1.bisim1FAccNull)
    ultimately show ?thesis using s by auto blast
  next
    case (FAcc1Throw a)
    note [simp] = e = Throw a h' = h xs' = xs ta = ε e' = Throw a
    have τ: "τmove1 P h (eF{D})" by(auto intro: τmove1FAccThrow)
    from bisim have "xcp = a  xcp = None" by(auto dest: bisim1_ThrowD)
    thus ?thesis
    proof
      assume [simp]: "xcp = a"
      with bisim have "P,EF{D}, h  (Throw a, xs)  (stk, loc, pc, xcp)"
        by(auto intro: bisim1_bisims1.bisim1FAccThrow)
      thus ?thesis using τ by(fastforce)
    next
      assume [simp]: "xcp = None"
      with bisim obtain pc'
        where "τExec_mover_a P t E h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        and bisim': "P, E, h  (Throw a, xs)  ([Addr a], loc, pc', a)" and [simp]: "xs = loc"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t (EF{D}) h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        by-(rule FAcc_τExecrI)
      moreover from bisim' have "P, EF{D}, h  (Throw a, xs)  ([Addr a], loc, pc', a)"
        by(rule bisim1_bisims1.bisim1FAccThrow)
      ultimately show ?thesis using τ by auto
    qed
  qed
next
  case bisim1FAccThrow thus ?case by auto
next
  case bisim1FAccNull thus ?case by auto
next
  case (bisim1FAss1 e1 n e1' xs stk loc pc xcp e2 F D)
  note IH1 = bisim1FAss1.IH(2)
  note IH2 = bisim1FAss1.IH(4)
  note bisim1 = P,e1,h  (e1', xs)  (stk, loc, pc, xcp)
  note bisim2 = xs. P,e2,h  (e2, xs)  ([], xs, 0, None)
  note bsok = ‹bsok (e1F{D} := e2) n
  from ‹True,P,t ⊢1 e1'F{D} := e2,(h, xs) -ta e',(h', xs') show ?case
  proof cases
    case (FAss1Red1 E')
    note [simp] = e' = E'F{D} := e2
      and red = ‹True,P,t ⊢1 e1',(h, xs) -ta E',(h', xs')
    from red have "τmove1 P h (e1'F{D} := e2) = τmove1 P h e1'" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover from red have "call1 (e1'F{D} := e2) = call1 e1'" by auto
    moreover from IH1[OF red] bsok
    obtain pc'' stk'' loc'' xcp'' where bisim: "P,e1,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and redo: "?exec ta e1 e1' E' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    from bisim
    have "P,e1F{D} := e2,h'  (E'F{D} := e2, xs')  (stk'', loc'', pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1FAss1)
    moreover { 
      assume "no_call2 e1 pc"
      hence "no_call2 (e1F{D} := e2) pc  pc = length (compE2 e1)" by(auto simp add: no_call2_def) }
    ultimately show ?thesis using redo
      by(auto simp del: call1.simps calls1.simps split: if_split_asm split del: if_split)(blast intro: FAss_τExecrI1 FAss_τExectI1 exec_move_FAssI1)+
  next
    case (FAss1Red2 E' v)
    note [simp] = e1' = Val v e' = Val vF{D} := E'
      and red = ‹True,P,t ⊢1 e2,(h, xs) -ta E',(h', xs')
    from red have τ: "τmove1 P h (Val vF{D} := e2) = τmove1 P h e2" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim1 have s: "xcp = None" "xs = loc"
      and exec1: "τExec_mover_a P t e1 h (stk, loc, pc, None) ([v], xs, length (compE2 e1), None)"
      by(auto dest: bisim1Val2D1)
    from exec1 have "τExec_mover_a P t (e1F{D} := e2) h (stk, loc, pc, None) ([v], xs, length (compE2 e1), None)"
      by(rule FAss_τExecrI1)
    moreover
    from IH2[OF red] bsok obtain pc'' stk'' loc'' xcp''
      where bisim': "P,e2,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and exec': "?exec ta e2 e2 E' h [] xs 0 None h' pc'' stk'' loc'' xcp''" by auto
    have "?exec ta (e1F{D} := e2) (Val vF{D} := e2) (Val vF{D} := E') h ([] @ [v]) xs (length (compE2 e1) + 0) None h' (length (compE2 e1) + pc'') (stk'' @ [v]) loc'' xcp''"
    proof(cases "τmove1 P h (Val vF{D} := e2)")
      case True
      with exec' τ have [simp]: "h = h'" and e: "sim_move e2 E' P t e2 h ([], xs, 0, None) (stk'', loc'', pc'', xcp'')" by auto
      from e have "sim_move (Val vF{D} := e2) (Val vF{D} := E') P t (e1F{D} := e2) h ([] @ [v], xs, length (compE2 e1) + 0, None) (stk'' @ [v], loc'', length (compE2 e1) + pc'', xcp'')"
        by(fastforce dest: FAss_τExecrI2 FAss_τExectI2 simp del: compE2.simps compEs2.simps)
      with True show ?thesis by auto
    next
      case False
      with exec' τ obtain pc' stk' loc' xcp'
        where e: "τExec_mover_a P t e2 h ([], xs, 0, None) (stk', loc', pc', xcp')"
        and e': "exec_move_a P t e2 h (stk', loc', pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'', loc'', pc'', xcp'')"
        and τ': "¬ τmove2 (compP2 P) h stk' e2 pc' xcp'" 
        and call: "call1 e2 = None  no_call2 e2 0  pc' = 0  stk' = []  loc' = xs  xcp' = None" by auto
      from e have "τExec_mover_a P t (e1F{D} := e2) h ([] @ [v], xs, length (compE2 e1) + 0, None) (stk' @ [v], loc', length (compE2 e1) + pc', xcp')"
        by(rule FAss_τExecrI2)
      moreover from e' have "exec_move_a P t (e1F{D} := e2) h (stk' @ [v], loc', length (compE2 e1) + pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'' @ [v], loc'', length (compE2 e1) + pc'', xcp'')"
        by(rule exec_move_FAssI2)
      moreover from e' have "pc' < length (compE2 e2)" by(auto elim: exec_meth.cases)
      with τ' e' have "¬ τmove2 (compP2 P) h (stk' @ [v]) (e1F{D} := e2) (length (compE2 e1) + pc') xcp'"
        by(auto simp add: τmove2_iff τinstr_stk_drop_exec_move)
      moreover have "call1 (e1'F{D} := e2) = call1 e2" by simp
      moreover have "no_call2 e2 0  no_call2 (e1F{D} := e2) (length (compE2 e1))"
        by(auto simp add: no_call2_def)
      ultimately show ?thesis using False call
        by(auto simp del: split_paired_Ex call1.simps calls1.simps) blast
    qed
    moreover from bisim'
    have "P,e1F{D} := e2,h'  (Val vF{D} := E', xs')  ((stk'' @ [v]), loc'', length (compE2 e1) + pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1FAss2)
    moreover from bisim1 have "pc  length (compE2 e1)  no_call2 (e1F{D} := e2) pc"
      by(auto simp add: no_call2_def dest: bisim_Val_pc_not_Invoke bisim1_pc_length_compE2)
    ultimately show ?thesis using τ exec1 s
      apply(auto simp del: split_paired_Ex call1.simps calls1.simps split: if_split_asm split del: if_split)
      apply(blast intro: τExec_mover_trans|fastforce elim!: τExec_mover_trans simp del: split_paired_Ex call1.simps calls1.simps)+
      done
  next
    case (Red1FAss a v)
    note [simp] = e1' = addr a e2 = Val v ta = WriteMem a (CField D F) v e' = unit› xs' = xs
      and "write" = heap_write h a (CField D F) v h'
    have τ: "¬ τmove1 P h (e1'F{D} := e2)" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim1 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t e1 h (stk, loc, pc, xcp) ([Addr a], loc, length (compE2 e1), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1F{D} := e2) h (stk, loc, pc, xcp) ([Addr a], loc, length (compE2 e1), None)"
      by-(rule FAss_τExecrI1)
    also have "τmove2 (compP2 P) h [Addr a] (e1F{D} := Val v) (length (compE2 e1)) None" by(simp add: τmove2_iff)
    hence "τExec_mover_a P t (e1F{D} := e2) h ([Addr a], loc, length (compE2 e1), None) ([v, Addr a], loc, Suc (length (compE2 e1)), None)"
      by-(rule τExecr1step, auto intro!: exec_instr simp add: exec_move_def compP2_def)
    also (rtranclp_trans) from "write"
    have "exec_move_a P t (e1F{D} := e2) h ([v, Addr a], loc, Suc (length (compE2 e1)), None) WriteMem a (CField D F) v
                                      h' ([], loc, Suc (Suc (length (compE2 e1))), None)"
      unfolding exec_move_def by(auto intro!: exec_instr)
    moreover have "τmove2 (compP2 P) h [v, Addr a] (e1F{D} := e2) (Suc (length (compE2 e1))) None  False"
      by(simp add: τmove2_iff)
    moreover
    have "P, e1F{D} := e2, h'  (unit, loc)  ([], loc, Suc (length (compE2 e1) + length (compE2 e2)), None)"
      by(rule bisim1_bisims1.bisim1FAss3)
    ultimately show ?thesis using s τ by(auto simp del: fun_upd_apply simp add: ta_upd_simps) blast
  next
    case (Red1FAssNull v)
    note [simp] = e1' = null› e2 = Val v xs' = xs ta = ε e' = THROW NullPointer› h' = h
    have τ: "¬ τmove1 P h (e1'F{D} := e2)" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim1 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t e1 h (stk, loc, pc, xcp) ([Null], loc, length (compE2 e1), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1F{D} := e2) h (stk, loc, pc, xcp) ([Null], loc, length (compE2 e1), None)"
      by-(rule FAss_τExecrI1)
    also have "τmove2 (compP2 P) h [Null] (e1F{D} := Val v) (length (compE2 e1)) None" by(simp add: τmove2_iff)
    hence "τExec_mover_a P t (e1F{D} := e2) h ([Null], loc, length (compE2 e1), None) ([v, Null], loc, Suc (length (compE2 e1)), None)"
      by-(rule τExecr1step, auto intro!: exec_instr simp add: exec_move_def compP2_def)
    also (rtranclp_trans)
    have "exec_move_a P t (e1F{D} := e2) h ([v, Null], loc, Suc (length (compE2 e1)), None) ε
                                      h' ([v, Null], loc, Suc (length (compE2 e1)), addr_of_sys_xcpt NullPointer)"
      by(auto intro!: exec_instr simp add: exec_move_def)
    moreover have "τmove2 (compP2 P) h [v, Null] (e1F{D} := e2) (Suc (length (compE2 e1))) None  False"
      by(simp add: τmove2_iff)
    moreover
    have "P, e1F{D} := e2, h  (THROW NullPointer, loc)  ([v, Null], loc, length (compE2 e1) + length (compE2 e2), addr_of_sys_xcpt NullPointer)"
      by(rule bisim1_bisims1.bisim1FAssNull)
    ultimately show ?thesis using s τ by(auto simp del: fun_upd_apply) blast
  next
    case (FAss1Throw1 a)
    note [simp] = e1' = Throw a ta = ε e' = Throw a h' = h xs' = xs
    have τ: "τmove1 P h (Throw aF{D} := e2)" by(rule τmove1FAssThrow1)
    from bisim1 have "xcp = a  xcp = None" by(auto dest: bisim1_ThrowD)
    thus ?thesis
    proof
      assume [simp]: "xcp = a"
      with bisim1
      have "P, e1F{D} := e2, h  (Throw a, xs)  (stk, loc, pc, xcp)"
        by(auto intro: bisim1_bisims1.intros)
      thus ?thesis using τ by(fastforce)
    next
      assume [simp]: "xcp = None"
      with bisim1 obtain pc' where "τExec_mover_a P t e1 h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        and bisim': "P, e1, h  (Throw a, xs)  ([Addr a], loc, pc', a)"
        and [simp]: "xs = loc"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t (e1F{D} := e2) h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        by-(rule FAss_τExecrI1)
      moreover from bisim'
      have "P, e1F{D} := e2, h (Throw a, xs)  ([Addr a], loc, pc', a)"
        by(rule bisim1_bisims1.bisim1FAssThrow1)
      ultimately show ?thesis using τ by auto
    qed
  next
    case (FAss1Throw2 v ad)
    note [simp] = e1' = Val v e2 = Throw ad e' = Throw ad h' = h xs' = xs
    from bisim1 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t e1 h (stk, loc, pc, xcp) ([v], loc, length (compE2 e1), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1F{D} := Throw ad) h (stk, loc, pc, xcp) ([v], loc, length (compE2 e1), None)"
      by-(rule FAss_τExecrI1)
    also have "τExec_mover_a P t (e1F{D} := Throw ad) h ([v], loc, length (compE2 e1), None) ([Addr ad, v], loc, Suc (length (compE2 e1)), ad)"
      by(rule τExecr2step)(auto simp add: exec_move_def exec_meth_instr τmove2_iff τmove1.simps τmoves1.simps)
    also (rtranclp_trans)
    have "P,e1F{D}:=Throw ad,h  (Throw ad, loc)  ([Addr ad] @ [v], loc, (length (compE2 e1) + length (compE2 (addr ad))), ad)"
      by(rule bisim1FAssThrow2[OF bisim1Throw2])
    moreover have "τmove1 P h (FAss e1' F D (Throw ad))" by(auto intro: τmove1FAssThrow2)
    ultimately show ?thesis using s by auto
  qed
next
  case (bisim1FAss2 e2 n e2' xs stk loc pc xcp e1 F D v1)
  note IH2 = bisim1FAss2.IH(2)
  note bisim1 = xs. P,e1,h  (e1, xs)  ([], xs, 0, None)
  note bisim2 = P,e2,h  (e2', xs)  (stk, loc, pc, xcp)
  note bsok = ‹bsok (e1F{D} := e2) n
  note red = ‹True,P,t ⊢1 Val v1F{D} := e2',(h, xs) -ta e',(h', xs')
  from red show ?case
  proof cases
    case (FAss1Red2 E')
    note [simp] = e' = Val v1F{D} := E'
      and red = ‹True,P,t ⊢1 e2',(h, xs) -ta E',(h', xs')
    from IH2[OF red] bsok obtain pc'' stk'' loc'' xcp''
      where bisim': "P,e2,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and exec': "?exec ta e2 e2' E' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    from red have τ: "τmove1 P h (Val v1F{D} := e2') = τmove1 P h e2'" by(auto simp add: τmove1.simps τmoves1.simps)
    have "no_call2 e2 pc  no_call2 (e1F{D} := e2) (length (compE2 e1) + pc)" by(auto simp add: no_call2_def)
    hence "?exec ta (e1F{D} := e2) (Val v1F{D} := e2') (Val v1F{D} := E') h (stk @ [v1]) loc (length (compE2 e1) + pc) xcp h' (length (compE2 e1) + pc'') (stk'' @ [v1]) loc'' xcp''"
      using exec' τ
      apply(cases "τmove1 P h (Val v1F{D} := e2')")
      apply(auto)
      apply(blast intro: FAss_τExecrI2 FAss_τExectI2 exec_move_FAssI2)
      apply(blast intro: FAss_τExecrI2 FAss_τExectI2 exec_move_FAssI2)
      apply(rule exI conjI FAss_τExecrI2 exec_move_FAssI2|assumption)+
      apply(fastforce simp add: τinstr_stk_drop_exec_move τmove2_iff split: if_split_asm)
      apply(rule exI conjI FAss_τExecrI2 exec_move_FAssI2|assumption)+
      apply(fastforce simp add: τinstr_stk_drop_exec_move τmove2_iff split: if_split_asm)
      apply(rule exI conjI FAss_τExecrI2 exec_move_FAssI2 rtranclp.rtrancl_refl|assumption)+
      apply(fastforce simp add: τinstr_stk_drop_exec_move τmove2_iff split: if_split_asm)+
      done
    moreover from bisim'
    have "P,e1F{D} := e2,h'  (Val v1F{D} := E', xs')  (stk''@[v1], loc'', length (compE2 e1) + pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1FAss2)
    ultimately show ?thesis using τ by auto blast+
  next
    case (Red1FAss a v)
    note [simp] = v1 = Addr a e2' = Val v ta = WriteMem a (CField D F) v e' = unit› xs' = xs
      and ha = heap_write h a (CField D F) v h'
    have τ: "¬ τmove1 P h (addr aF{D} := e2')" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim2 have s: "xcp = None" "xs = loc" 
      and "τExec_mover_a P t e2 h (stk, loc, pc, xcp) ([v], loc, length (compE2 e2), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1F{D} := e2) h (stk @ [v1], loc, length (compE2 e1) + pc, xcp) ([v] @ [v1], loc, length (compE2 e1) + length (compE2 e2), None)"
      by-(rule FAss_τExecrI2)
    moreover from ha
    have "exec_move_a P t (e1F{D} := e2) h ([v, Addr a], loc, length (compE2 e1) + length (compE2 e2), None) WriteMem a (CField D F) v
                                      h' ([], loc, Suc (length (compE2 e1) + length (compE2 e2)), None)"
      by(auto intro!: exec_instr simp add: exec_move_def)
    moreover have "τmove2 (compP2 P) h [v, Addr a] (e1F{D} := e2) (length (compE2 e1) + length (compE2 e2)) None  False"
      by(simp add: τmove2_iff)
    moreover
    have "P, e1F{D} := e2, h'  (unit, loc)  ([], loc, Suc (length (compE2 e1) + length (compE2 e2)), None)"
      by(rule bisim1_bisims1.bisim1FAss3)
    ultimately show ?thesis using s τ by(auto simp del: fun_upd_apply simp add: ta_upd_simps) blast
  next
    case (Red1FAssNull v)
    note [simp] = v1 = Null› e2' = Val v xs' = xs ta = ε e' = THROW NullPointer› h' = h
    have τ: "¬ τmove1 P h (nullF{D} := e2')" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim2 have s: "xcp = None" "xs = loc" 
      and "τExec_mover_a P t e2 h (stk, loc, pc, xcp) ([v], loc, length (compE2 e2), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1F{D} := e2) h (stk @ [Null], loc, length (compE2 e1) + pc, xcp) ([v] @ [Null], loc, length (compE2 e1) + length (compE2 e2), None)"
      by-(rule FAss_τExecrI2)
    moreover have "exec_move_a P t (e1F{D} := e2) h ([v, Null], loc, length (compE2 e1) + length (compE2 e2), None) ε
                                      h' ([v, Null], loc, length (compE2 e1) + length (compE2 e2), addr_of_sys_xcpt NullPointer)"
      by(auto intro!: exec_instr simp add: exec_move_def)
    moreover have "τmove2 (compP2 P) h [v, Null] (e1F{D} := e2) (length (compE2 e1) + length (compE2 e2)) None  False"
      by(simp add: τmove2_iff)
    moreover
    have "P, e1F{D} := e2, h  (THROW NullPointer, loc)  ([v, Null], loc, length (compE2 e1) + length (compE2 e2), addr_of_sys_xcpt NullPointer)"
      by(rule bisim1_bisims1.bisim1FAssNull)
    ultimately show ?thesis using s τ by(auto simp del: fun_upd_apply) blast
  next
    case (FAss1Throw2 a)
    note [simp] = e2' = Throw a ta = ε h' = h xs' = xs e' = Throw a
    have τ: "τmove1 P h (FAss (Val v1) F D (Throw a))" by(rule τmove1FAssThrow2)
    from bisim2 have "xcp = a  xcp = None" by(auto dest: bisim1_ThrowD)
    thus ?thesis
    proof
      assume [simp]: "xcp = a"
      with bisim2
      have "P, e1F{D} := e2, h  (Throw a, xs)  (stk @ [v1], loc, length (compE2 e1) + pc, xcp)"
        by(auto intro: bisim1FAssThrow2)
      thus ?thesis using τ by(fastforce)
    next
      assume [simp]: "xcp = None"
      with bisim2 obtain pc'
        where "τExec_mover_a P t e2 h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        and bisim': "P, e2, h  (Throw a, xs)  ([Addr a], loc, pc', a)" and [simp]: "xs = loc"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t (e1F{D} := e2) h (stk @ [v1], loc, length (compE2 e1) + pc, None) ([Addr a] @ [v1], loc, length (compE2 e1) + pc', a)"
        by-(rule FAss_τExecrI2)
      moreover from bisim'
      have "P, e1F{D} := e2, h  (Throw a, xs)  ([Addr a]@[v1], loc, length (compE2 e1) + pc', a)"
        by-(rule bisim1FAssThrow2, auto)
      ultimately show ?thesis using τ by auto
    qed
  qed auto
next
  case bisim1FAssThrow1 thus ?case by fastforce
next
  case bisim1FAssThrow2 thus ?case by fastforce
next
  case bisim1FAssNull thus ?case by fastforce
next
  case bisim1FAss3 thus ?case by fastforce
next
  case (bisim1CAS1 e1 n e1' xs stk loc pc xcp e2 e3 D F)
  note IH1 = bisim1CAS1.IH(2)
  note IH2 = bisim1CAS1.IH(4)
  note IH3 = bisim1CAS1.IH(6)
  note bisim1 = P,e1,h  (e1', xs)  (stk, loc, pc, xcp)
  note bisim2 = xs. P,e2,h  (e2, xs)  ([], xs, 0, None)
  note bisim3 = xs. P,e3,h  (e3, xs)  ([], xs, 0, None)
  note bsok = ‹bsok _ n
  from ‹True,P,t ⊢1 _,(h, xs) -ta e',(h', xs') show ?case
  proof cases
    case (CAS1Red1 E')
    note [simp] = e' = E'∙compareAndSwap(DF, e2, e3)
      and red = ‹True,P,t ⊢1 e1',(h, xs) -ta E',(h', xs')
    from red have "τmove1 P h (e1'∙compareAndSwap(DF, e2, e3)) = τmove1 P h e1'" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover from red have "call1 (e1'∙compareAndSwap(DF, e2, e3)) = call1 e1'" by auto
    moreover from IH1[OF red] bsok
    obtain pc'' stk'' loc'' xcp'' where bisim: "P,e1,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and redo: "?exec ta e1 e1' E' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    from bisim 
    have "P,e1∙compareAndSwap(DF, e2, e3),h'  (E'∙compareAndSwap(DF, e2, e3), xs')  (stk'', loc'', pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1CAS1)
    moreover { 
      assume "no_call2 e1 pc"
      hence "no_call2 (e1∙compareAndSwap(DF, e2, e3)) pc  pc = length (compE2 e1)" by(auto simp add: no_call2_def) }
    ultimately show ?thesis using redo
      by(auto simp del: call1.simps calls1.simps split: if_split_asm split del: if_split)(blast intro: CAS_τExecrI1 CAS_τExectI1 exec_move_CASI1)+
  next
    case (CAS1Red2 E' v)
    note [simp] = e1' = Val v e' = Val v∙compareAndSwap(DF, E', e3)
      and red = ‹True,P,t ⊢1 e2,(h, xs) -ta E',(h', xs')
    from red have τ: "τmove1 P h (Val v∙compareAndSwap(DF, e2, e3)) = τmove1 P h e2" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim1 have s: "xcp = None" "xs = loc"
      and exec1: "τExec_mover_a P t e1 h (stk, loc, pc, None) ([v], xs, length (compE2 e1), None)"
      by(auto dest: bisim1Val2D1)
    from exec1 have "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h (stk, loc, pc, None) ([v], xs, length (compE2 e1), None)"
      by(rule CAS_τExecrI1)
    moreover
    from IH2[OF red] bsok obtain pc'' stk'' loc'' xcp''
      where bisim': "P,e2,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and exec': "?exec ta e2 e2 E' h [] xs 0 None h' pc'' stk'' loc'' xcp''" by auto
    have "?exec ta (e1∙compareAndSwap(DF, e2, e3)) (Val v∙compareAndSwap(DF, e2, e3)) (Val v∙compareAndSwap(DF, E', e3)) h ([] @ [v]) xs (length (compE2 e1) + 0) None h' (length (compE2 e1) + pc'') (stk'' @ [v]) loc'' xcp''"
    proof(cases "τmove1 P h (Val v∙compareAndSwap(DF, e2, e3))")
      case True
      with exec' τ have [simp]: "h = h'" and e: "sim_move e2 E' P t e2 h ([], xs, 0, None) (stk'', loc'', pc'', xcp'')" by auto
      from e have "sim_move (e1∙compareAndSwap(DF, e2, e3)) (e1∙compareAndSwap(DF, E', e3)) P t (e1∙compareAndSwap(DF, e2, e3)) h ([] @ [v], xs, length (compE2 e1) + 0, None) (stk'' @ [v], loc'', length (compE2 e1) + pc'', xcp'')"
        by(fastforce dest: CAS_τExecrI2 CAS_τExectI2)
      with True show ?thesis by auto
    next
      case False
      with exec' τ obtain pc' stk' loc' xcp'
        where e: "τExec_mover_a P t e2 h ([], xs, 0, None) (stk', loc', pc', xcp')"
        and e': "exec_move_a P t e2 h (stk', loc', pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'', loc'', pc'', xcp'')"
        and τ': "¬ τmove2 (compP2 P) h stk' e2 pc' xcp'" 
        and call: "call1 e2 = None  no_call2 e2 0  pc' = 0  stk' = []  loc' = xs  xcp' = None" by auto
      from e have "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h ([] @ [v], xs, length (compE2 e1) + 0, None) (stk' @ [v], loc', length (compE2 e1) + pc', xcp')" by(rule CAS_τExecrI2)
      moreover from e' have "exec_move_a P t (e1∙compareAndSwap(DF, e2, e3)) h (stk' @ [v], loc', length (compE2 e1) + pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'' @ [v], loc'', length (compE2 e1) + pc'', xcp'')"
        by(rule exec_move_CASI2)
      moreover from e' have "pc' < length (compE2 e2)" by(auto elim: exec_meth.cases)
      with τ' e' have "¬ τmove2 (compP2 P) h (stk' @ [v]) (e1∙compareAndSwap(DF, e2, e3)) (length (compE2 e1) + pc') xcp'"
        by(auto simp add: τinstr_stk_drop_exec_move τmove2_iff)
      moreover from red have "call1 (e1'∙compareAndSwap(DF, e2, e3)) = call1 e2" by auto
      moreover have "no_call2 e2 0  no_call2 (e1∙compareAndSwap(DF, e2, e3)) (length (compE2 e1))"
        by(auto simp add: no_call2_def)
      ultimately show ?thesis using False call
        by(auto simp del: split_paired_Ex call1.simps calls1.simps) blast
    qed
    moreover from bisim'
    have "P,e1∙compareAndSwap(DF, e2, e3),h'  (Val v∙compareAndSwap(DF, E', e3), xs')  ((stk'' @ [v]), loc'', length (compE2 e1) + pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1CAS2)
    moreover from bisim1 have "pc  length (compE2 e1)  no_call2 (e1∙compareAndSwap(DF, e2, e3)) pc"
      by(auto simp add: no_call2_def dest: bisim_Val_pc_not_Invoke bisim1_pc_length_compE2)
    ultimately show ?thesis using τ exec1 s
      apply(auto simp del: split_paired_Ex call1.simps calls1.simps split: if_split_asm split del: if_split)
      apply(blast intro: τExec_mover_trans|fastforce elim!: τExec_mover_trans simp del: split_paired_Ex call1.simps calls1.simps)+
      done
  next
    case (CAS1Red3 E' v v')
    note [simp] = e2 = Val v' e1' = Val v e' = Val v∙compareAndSwap(DF, Val v', E')
      and red = ‹True,P,t ⊢1 e3,(h, xs) -ta E',(h', xs')
    from red have τ: "τmove1 P h (Val v∙compareAndSwap(DF, Val v', e3)) = τmove1 P h e3" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim1 have s: "xcp = None" "xs = loc"
      and exec1: "τExec_mover_a P t e1 h (stk, loc, pc, None) ([] @ [v], xs, length (compE2 e1) + 0, None)"
      by(auto dest: bisim1Val2D1)
    from exec1 have "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h (stk, loc, pc, None) ([] @ [v], xs, length (compE2 e1) + 0, None)"
      by(rule CAS_τExecrI1)
    also from bisim2[of xs] 
    have "τExec_mover_a P t e2 h ([], xs, 0, None) ([v'], xs, length (compE2 e2), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h ([] @ [v], xs, length (compE2 e1) + 0, None) ([v'] @ [v], xs, length (compE2 e1) + length (compE2 e2), None)"
      by(rule CAS_τExecrI2)
    also (rtranclp_trans) from IH3[OF red] bsok obtain pc'' stk'' loc'' xcp''
      where bisim': "P,e3,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and exec': "?exec ta e3 e3 E' h [] xs 0 None h' pc'' stk'' loc'' xcp''" by auto
    have "?exec ta (e1∙compareAndSwap(DF, e2, e3)) (Val v∙compareAndSwap(DF, Val v', e3)) (Val v∙compareAndSwap(DF, Val v', E')) h ([] @ [v', v]) xs (length (compE2 e1) + length (compE2 e2) + 0) None h' (length (compE2 e1) + length (compE2 e2) + pc'') (stk'' @ [v', v]) loc'' xcp''"
    proof(cases "τmove1 P h (Val v∙compareAndSwap(DF, Val v', e3))")
      case True
      with exec' τ have [simp]: "h = h'" and e: "sim_move e3 E' P t e3 h ([], xs, 0, None) (stk'', loc'', pc'', xcp'')" by auto
      from e have "sim_move (Val v∙compareAndSwap(DF, Val v', e3)) (Val v∙compareAndSwap(DF, Val v', E')) P t (e1∙compareAndSwap(DF, e2, e3)) h ([] @ [v', v], xs, length (compE2 e1) + length (compE2 e2) + 0, None) (stk'' @ [v', v], loc'', length (compE2 e1) + length (compE2 e2) + pc'', xcp'')"
        by(fastforce dest: CAS_τExectI3 CAS_τExecrI3 simp del: compE2.simps compEs2.simps)
      with True show ?thesis by auto
    next
      case False
      with exec' τ obtain pc' stk' loc' xcp'
        where e: "τExec_mover_a P t e3 h ([], xs, 0, None) (stk', loc', pc', xcp')"
        and e': "exec_move_a P t e3 h (stk', loc', pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'', loc'', pc'', xcp'')"
        and τ': "¬ τmove2 (compP2 P) h stk' e3 pc' xcp'" 
        and call: "call1 e3 = None  no_call2 e3 0  pc' = 0  stk' = []  loc' = xs  xcp' = None" by auto
      from e have "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h ([] @ [v', v], xs, length (compE2 e1) + length (compE2 e2) + 0, None) (stk' @ [v', v], loc', length (compE2 e1) + length (compE2 e2) + pc', xcp')" by(rule CAS_τExecrI3)
      moreover from e' have "exec_move_a P t (e1∙compareAndSwap(DF, e2, e3)) h (stk' @ [v', v], loc', length (compE2 e1) + length (compE2 e2) + pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'' @ [v', v], loc'', length (compE2 e1) + length (compE2 e2) + pc'', xcp'')"
        by(rule exec_move_CASI3)
      moreover from e' τ'
      have "¬ τmove2 (compP2 P) h (stk' @ [v', v]) (e1∙compareAndSwap(DF, e2, e3)) (length (compE2 e1) + length (compE2 e2) + pc') xcp'"
        by(auto simp add: τinstr_stk_drop_exec_move τmove2_iff)
      moreover have "call1 (e1'∙compareAndSwap(DF, e2, e3)) = call1 e3" by simp
      moreover have "no_call2 e3 0  no_call2 (e1∙compareAndSwap(DF, e2, e3)) (length (compE2 e1) + length (compE2 e2))"
        by(auto simp add: no_call2_def)
      ultimately show ?thesis using False call
        by(auto simp del: split_paired_Ex call1.simps calls1.simps) blast
    qed
    moreover from bisim'
    have "P,e1∙compareAndSwap(DF, e2, e3),h'  (Val v∙compareAndSwap(DF, Val v', E'), xs')  ((stk'' @ [v', v]),  loc'', length (compE2 e1) + length (compE2 e2) + pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1CAS3) 
    moreover from bisim1 have "pc  length (compE2 e1) + length (compE2 e2)  no_call2 (e1∙compareAndSwap(DF, e2, e3)) pc"
      by(auto simp add: no_call2_def dest: bisim_Val_pc_not_Invoke bisim1_pc_length_compE2)
    ultimately show ?thesis using τ exec1 s
      apply(auto simp del: split_paired_Ex call1.simps calls1.simps split: if_split_asm split del: if_split)
      apply(blast intro: τExec_mover_trans|fastforce elim!: τExec_mover_trans simp del: split_paired_Ex call1.simps calls1.simps)+
      done
  next
    case (CAS1Null v v')
    note [simp] = e1' = null› e' = THROW NullPointer› e2 = Val v xs' = xs ta = ε h' = h e3 = Val v'
    have τ: "¬ τmove1 P h (AAss null (Val v) (Val v'))" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim1 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t e1 h (stk, loc, pc, xcp) ([] @ [Null], loc, length (compE2 e1) + 0, None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h (stk, loc, pc, xcp) ([] @ [Null], loc, length (compE2 e1) + 0, None)"
      by-(rule CAS_τExecrI1)
    also from bisim2[of loc] have "τExec_mover_a P t e2 h ([], loc, 0, None) ([v], loc, length (compE2 e2) + 0, None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h ([] @ [Null], loc, length (compE2 e1) + 0, None) ([v] @ [Null], loc, length (compE2 e1) + (length (compE2 e2) + 0), None)"
      by(rule CAS_τExecrI2)
    also (rtranclp_trans) have "[v] @ [Null] = [] @ [v, Null]" by simp
    also note add.assoc[symmetric]
    also from bisim3[of loc] have "τExec_mover_a P t e3 h ([], loc, 0, None) ([v'], loc, length (compE2 e3), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h ([] @ [v, Null], loc, length (compE2 e1) + length (compE2 e2) + 0, None) ([v'] @ [v, Null], loc, length (compE2 e1) + length (compE2 e2) + length (compE2 e3), None)"
      by(rule CAS_τExecrI3)
    also (rtranclp_trans)
    have "exec_move_a P t (e1∙compareAndSwap(DF, e2, e3)) h ([v', v, Null], loc, length (compE2 e1) + length (compE2 e2) + length (compE2 e3), None) ε
                                 h ([v', v, Null], loc, length (compE2 e1) + length (compE2 e2) + length (compE2 e3), addr_of_sys_xcpt NullPointer)"
      unfolding exec_move_def by-(rule exec_instr, auto simp add: is_Ref_def)
    moreover have "τmove2 (compP2 P) h [v', v, Null] (e1∙compareAndSwap(DF, e2, e3)) (length (compE2 e1) + length (compE2 e2) + length (compE2 e3)) None  False"
      by(simp add: τmove2_iff)
    moreover
    have "P, e1∙compareAndSwap(DF, e2, e3), h'  (THROW NullPointer, loc)  ([v', v, Null], loc, length (compE2 e1) + length (compE2 e2) + length (compE2 e3), addr_of_sys_xcpt NullPointer)"
      by(rule bisim1_bisims1.bisim1CASFail)
    ultimately show ?thesis using s τ by(auto simp add: τmove1.simps) blast
  next
    case (Red1CASSucceed a v v')
    hence [simp]: "e1' = addr a" "e' = true" "e2 = Val v"
      "ta = ReadMem a (CField D F) v, WriteMem a (CField D F) v'" "xs' = xs" "e3 = Val v'"
      and read: "heap_read h a (CField D F) v"
      and "write": "heap_write h a (CField D F) v' h'" by auto
    have τ: "¬ τmove1 P h (CompareAndSwap (addr a) D F (Val v) (Val v'))" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim1 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t e1 h (stk, loc, pc, xcp) ([] @ [Addr a], loc, length (compE2 e1) + 0, None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h (stk, loc, pc, xcp) ([] @ [Addr a], loc, length (compE2 e1) + 0, None)"
      by-(rule CAS_τExecrI1)
    also from bisim2[of loc]
    have "τExec_mover_a P t e2 h ([], loc, 0, None) ([v], loc, length (compE2 e2) + 0, None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h ([] @ [Addr a], loc, length (compE2 e1) + 0, None) ([v] @ [Addr a], loc, length (compE2 e1) + (length (compE2 e2) + 0), None)"
      by(rule CAS_τExecrI2)
    also (rtranclp_trans) have "[v] @ [Addr a] = [] @ [v, Addr a]" by simp
    also note add.assoc[symmetric]
    also from bisim3[of loc] have "τExec_mover_a P t e3 h ([], loc, 0, None) ([v'], loc, length (compE2 e3), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h ([] @ [v, Addr a], loc, length (compE2 e1) + length (compE2 e2) + 0, None) ([v'] @ [v, Addr a], loc, length (compE2 e1) + length (compE2 e2) + length (compE2 e3), None)"
      by(rule CAS_τExecrI3)
    also (rtranclp_trans) from read "write"
    have "exec_move_a P t (e1∙compareAndSwap(DF, e2, e3)) h ([v', v, Addr a], loc, length (compE2 e1) + length (compE2 e2) + length (compE2 e3), None)
                                  ReadMem a (CField D F) v, WriteMem a (CField D F) v' 
                                 h' ([Bool True], loc, Suc (length (compE2 e1) + length (compE2 e2) + length (compE2 e3)), None)"
      unfolding exec_move_def by-(rule exec_instr, auto simp add: compP2_def is_Ref_def)
    moreover have "τmove2 (compP2 P) h [v', v, Addr a] (e1∙compareAndSwap(DF, e2, e3)) (length (compE2 e1) + length (compE2 e2) + length (compE2 e3)) None  False"
      by(simp add: τmove2_iff)
    moreover
    have "P, e1∙compareAndSwap(DF, e2, e3), h'  (true, loc)  ([Bool True], loc, length (compE2 (e1∙compareAndSwap(DF, e2, e3))), None)"
      by(rule bisim1Val2) simp
    ultimately show ?thesis using s τ by(auto simp add: ta_upd_simps) blast
  next
    case (Red1CASFail a v'' v v')
    hence [simp]: "e1' = addr a" "e' = false" "e2 = Val v" "h' = h"
      "ta = ReadMem a (CField D F) v''" "xs' = xs" "e3 = Val v'"
      and read: "heap_read h a (CField D F) v''" "v  v''" by auto
    have τ: "¬ τmove1 P h (CompareAndSwap (addr a) D F (Val v) (Val v'))" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim1 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t e1 h (stk, loc, pc, xcp) ([] @ [Addr a], loc, length (compE2 e1) + 0, None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h (stk, loc, pc, xcp) ([] @ [Addr a], loc, length (compE2 e1) + 0, None)"
      by-(rule CAS_τExecrI1)
    also from bisim2[of loc]
    have "τExec_mover_a P t e2 h ([], loc, 0, None) ([v], loc, length (compE2 e2) + 0, None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h ([] @ [Addr a], loc, length (compE2 e1) + 0, None) ([v] @ [Addr a], loc, length (compE2 e1) + (length (compE2 e2) + 0), None)"
      by(rule CAS_τExecrI2)
    also (rtranclp_trans) have "[v] @ [Addr a] = [] @ [v, Addr a]" by simp
    also note add.assoc[symmetric]
    also from bisim3[of loc] have "τExec_mover_a P t e3 h ([], loc, 0, None) ([v'], loc, length (compE2 e3), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h ([] @ [v, Addr a], loc, length (compE2 e1) + length (compE2 e2) + 0, None) ([v'] @ [v, Addr a], loc, length (compE2 e1) + length (compE2 e2) + length (compE2 e3), None)"
      by(rule CAS_τExecrI3)
    also (rtranclp_trans) from read
    have "exec_move_a P t (e1∙compareAndSwap(DF, e2, e3)) h ([v', v, Addr a], loc, length (compE2 e1) + length (compE2 e2) + length (compE2 e3), None)
                                  ReadMem a (CField D F) v'' 
                                 h ([Bool False], loc, Suc (length (compE2 e1) + length (compE2 e2) + length (compE2 e3)), None)"
      unfolding exec_move_def by-(rule exec_instr, auto simp add: compP2_def is_Ref_def)
    moreover have "τmove2 (compP2 P) h [v', v, Addr a] (e1∙compareAndSwap(DF, e2, e3)) (length (compE2 e1) + length (compE2 e2) + length (compE2 e3)) None  False"
      by(simp add: τmove2_iff)
    moreover
    have "P, e1∙compareAndSwap(DF, e2, e3), h  (false, loc)  ([Bool False], loc, length (compE2 (e1∙compareAndSwap(DF, e2, e3))), None)"
      by(rule bisim1Val2) simp
    ultimately show ?thesis using s τ by(auto simp add: ta_upd_simps)blast
  next
    case (CAS1Throw a)
    hence [simp]: "e1' = Throw a" "ta = ε" "e' = Throw a" "h' = h" "xs' = xs" by auto
    have τ: "τmove1 P h (Throw a∙compareAndSwap(DF, e2, e3))" by(rule τmove1CASThrow1)
    from bisim1 have "xcp = a  xcp = None" by(auto dest: bisim1_ThrowD)
    thus ?thesis
    proof
      assume [simp]: "xcp = a"
      with bisim1 have "P, e1∙compareAndSwap(DF, e2, e3), h  (Throw a, xs)  (stk, loc, pc, xcp)"
        by(auto intro: bisim1_bisims1.intros)
      thus ?thesis using τ by(fastforce)
    next
      assume [simp]: "xcp = None"
      with bisim1 obtain pc' where "τExec_mover_a P t e1 h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        and bisim': "P, e1, h  (Throw a, xs)  ([Addr a], loc, pc', a)"
        and [simp]: "xs = loc"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        by-(rule CAS_τExecrI1)
      moreover from bisim' 
      have "P, e1∙compareAndSwap(DF, e2, e3), h  (Throw a, xs)  ([Addr a], loc, pc', a)"
        by(auto intro: bisim1_bisims1.bisim1CASThrow1)
      ultimately show ?thesis using τ by auto
    qed
  next
    case (CAS1Throw2 v ad)
    note [simp] = e1' = Val v e2 = Throw ad ta = ε e' = Throw ad h' = h xs' = xs
    from bisim1 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t e1 h (stk, loc, pc, xcp) ([v], loc, length (compE2 e1), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1∙compareAndSwap(DF, Throw ad, e3)) h (stk, loc, pc, xcp) ([v], loc, length (compE2 e1), None)"
      by-(rule CAS_τExecrI1)
    also have "τExec_mover_a P t (e1∙compareAndSwap(DF, Throw ad, e3)) h ([v], loc, length (compE2 e1), None) ([Addr ad, v], loc, Suc (length (compE2 e1)), ad)"
      by(rule τExecr2step)(auto simp add: exec_move_def exec_meth_instr τmove2_iff τmove1.simps τmoves1.simps)
    also (rtranclp_trans)
    have "P,e1∙compareAndSwap(DF, Throw ad, e3),h  (Throw ad, loc)  ([Addr ad] @ [v], loc, (length (compE2 e1) + length (compE2 (addr ad))), ad)"
      by(rule bisim1CASThrow2[OF bisim1Throw2])
    moreover have "τmove1 P h (e1'∙compareAndSwap(DF, Throw ad, e3))" by(auto intro: τmove1CASThrow2)
    ultimately show ?thesis using s by auto
  next
    case (CAS1Throw3 v v' ad)
    note [simp] = e1' = Val v e2 = Val v' e3 = Throw ad ta = ε e' = Throw ad h' = h xs' = xs
    from bisim1 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t e1 h (stk, loc, pc, xcp) ([v], loc, length (compE2 e1), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, Throw ad)) h (stk, loc, pc, xcp) ([v], loc, length (compE2 e1), None)"
      by-(rule CAS_τExecrI1)
    also from bisim2[of loc] have "τExec_mover_a P t e2 h ([], loc, 0, None) ([v'], loc, length (compE2 e2), None)"
      by(auto dest: bisim1Val2D1)
    from CAS_τExecrI2[OF this, of e1 D F e3 v]
    have "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, Throw ad)) h ([v], loc, length (compE2 e1), None) ([v', v], loc, length (compE2 e1) + length (compE2 e2), None)" by simp
    also (rtranclp_trans)
    have "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, Throw ad)) h ([v', v], loc, length (compE2 e1) + length (compE2 e2), None) ([Addr ad, v', v], loc, Suc (length (compE2 e1) + length (compE2 e2)), ad)"
      by(rule τExecr2step)(auto simp add: exec_move_def exec_meth_instr τmove2_iff τmove1.simps τmoves1.simps)
    also (rtranclp_trans)
    have "P,e1∙compareAndSwap(DF, e2, Throw ad),h  (Throw ad, loc)  ([Addr ad] @ [v', v], loc, (length (compE2 e1) + length (compE2 e2) + length (compE2 (addr ad))), ad)"
      by(rule bisim1CASThrow3[OF bisim1Throw2])
    moreover have "τmove1 P h (Val v∙compareAndSwap(DF, Val v', Throw ad))" by(auto intro: τmove1CASThrow3)
    ultimately show ?thesis using s by auto
  qed
next
  case (bisim1CAS2 e2 n e2' xs stk loc pc xcp e1 e3 D F v1)
  note IH2 = bisim1CAS2.IH(2)
  note IH3 = bisim1CAS2.IH(6)
  note bisim2 = P,e2,h  (e2', xs)  (stk, loc, pc, xcp)
  note bisim1 = xs. P,e1,h  (e1, xs)  ([], xs, 0, None)
  note bisim3 = xs. P,e3,h  (e3, xs)  ([], xs, 0, None)
  note bsok = ‹bsok (e1∙compareAndSwap(DF, e2, e3)) n
  from ‹True,P,t ⊢1 Val v1∙compareAndSwap(DF, e2', e3),(h, xs) -ta e',(h', xs') show ?case
  proof cases
    case (CAS1Red2 E')
    note [simp] = e' = Val v1∙compareAndSwap(DF, E', e3)
      and red = ‹True,P,t ⊢1 e2',(h, xs) -ta E',(h', xs')
    from red have τ: "τmove1 P h (Val v1∙compareAndSwap(DF, e2', e3)) = τmove1 P h e2'" by(auto simp add: τmove1.simps τmoves1.simps)
    from IH2[OF red] bsok obtain pc'' stk'' loc'' xcp''
      where bisim': "P,e2,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and exec': "?exec ta e2 e2' E' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    have "?exec ta (e1∙compareAndSwap(DF, e2, e3)) (Val v1∙compareAndSwap(DF, e2', e3)) (Val v1∙compareAndSwap(DF, E', e3)) h (stk @ [v1]) loc (length (compE2 e1) + pc) xcp h' (length (compE2 e1) + pc'') (stk'' @ [v1]) loc'' xcp''"
    proof(cases "τmove1 P h (Val v1∙compareAndSwap(DF, e2', e3))")
      case True
      with exec' τ have [simp]: "h = h'" and e: "sim_move e2' E' P t e2 h (stk, loc, pc, xcp) (stk'', loc'', pc'', xcp'')" by auto
      from e have "sim_move (Val v1∙compareAndSwap(DF, e2', e3)) (Val v1∙compareAndSwap(DF, E', e3)) P t (e1∙compareAndSwap(DF, e2, e3)) h (stk @ [v1], loc, length (compE2 e1) + pc, xcp) (stk'' @ [v1], loc'', length (compE2 e1) + pc'', xcp'')"
        by(fastforce dest: CAS_τExecrI2 CAS_τExectI2 simp del: compE2.simps compEs2.simps)
      with True show ?thesis by auto
    next
      case False
      with exec' τ obtain pc' stk' loc' xcp'
        where e: "τExec_mover_a P t e2 h (stk, loc, pc, xcp) (stk', loc', pc', xcp')"
        and e': "exec_move_a P t e2 h (stk', loc', pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'', loc'', pc'', xcp'')"
        and τ': "¬ τmove2 (compP2 P) h stk' e2 pc' xcp'" 
        and call: "call1 e2' = None  no_call2 e2 pc  pc' = pc  stk' = stk  loc' = loc  xcp' = xcp" by auto
      from e have "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h (stk @ [v1], loc, length (compE2 e1) + pc, xcp) (stk' @ [v1], loc', length (compE2 e1) + pc', xcp')" by(rule CAS_τExecrI2)
      moreover from e' have "exec_move_a P t (e1∙compareAndSwap(DF, e2, e3)) h (stk' @ [v1], loc', length (compE2 e1) + pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'' @ [v1], loc'', length (compE2 e1) + pc'', xcp'')"
        by(rule exec_move_CASI2)
      moreover from e' have "pc' < length (compE2 e2)" by(auto elim: exec_meth.cases)
      with τ' e' have "¬ τmove2 (compP2 P) h (stk' @ [v1]) (e1∙compareAndSwap(DF, e2, e3)) (length (compE2 e1) + pc') xcp'"
        by(auto simp add: τinstr_stk_drop_exec_move τmove2_iff)
      moreover from red have "call1 (Val v1∙compareAndSwap(DF, e2', e3)) = call1 e2'" by auto
      moreover have "no_call2 e2 pc  no_call2 (e1∙compareAndSwap(DF, e2, e3)) (length (compE2 e1) + pc)"
        by(auto simp add: no_call2_def)
      ultimately show ?thesis using False call by(auto simp del: split_paired_Ex call1.simps calls1.simps) 
    qed
    moreover from bisim'
    have "P,e1∙compareAndSwap(DF, e2, e3),h'  (Val v1∙compareAndSwap(DF, E', e3), xs')  ((stk'' @ [v1]),  loc'', length (compE2 e1) + pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1CAS2)
    ultimately show ?thesis
      apply(auto simp del: split_paired_Ex call1.simps calls1.simps split: if_split_asm split del: if_split)
      apply(blast intro: τExec_mover_trans)+
      done
  next
    case (CAS1Red3 E' v')
    note [simp] = e2' = Val v' e' = Val v1∙compareAndSwap(DF, Val v', E')
      and red = ‹True,P,t ⊢1 e3,(h, xs) -ta E',(h', xs')
    from red have τ: "τmove1 P h (Val v1∙compareAndSwap(DF, Val v', e3)) = τmove1 P h e3"
      by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim2 have s: "xcp = None" "xs = loc"
      and exec1: "τExec_mover_a P t e2 h (stk, loc, pc, xcp) ([v'], xs, length (compE2 e2), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h (stk @ [v1], loc, length (compE2 e1) + pc, xcp) ([v'] @ [v1], xs, length (compE2 e1) + length (compE2 e2), None)"
      by-(rule CAS_τExecrI2)
    moreover from IH3[OF red] bsok obtain pc'' stk'' loc'' xcp''
      where bisim': "P,e3,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and exec': "?exec ta e3 e3 E' h [] xs 0 None h' pc'' stk'' loc'' xcp''" by auto
    have "?exec ta (e1∙compareAndSwap(DF, e2, e3)) (Val v1∙compareAndSwap(DF, Val v', e3)) (Val v1Val v' := E') h ([] @ [v', v1]) xs (length (compE2 e1) + length (compE2 e2) + 0) None h' (length (compE2 e1) + length (compE2 e2) + pc'') (stk'' @ [v', v1]) loc'' xcp''"
    proof(cases "τmove1 P h (Val v1∙compareAndSwap(DF, Val v', e3))")
      case True
      with exec' τ have [simp]: "h = h'"
        and e: "sim_move e3 E' P t e3 h ([], xs, 0, None) (stk'', loc'', pc'', xcp'')" by auto
      from e have "sim_move (Val v1∙compareAndSwap(DF, Val v', e3)) (Val v1∙compareAndSwap(DF, Val v', E')) P t (e1∙compareAndSwap(DF, e2, e3)) h ([] @ [v', v1], xs, length (compE2 e1) + length (compE2 e2) + 0, None) (stk'' @ [v', v1], loc'', length (compE2 e1) + length (compE2 e2) + pc'', xcp'')"
        by(fastforce dest: CAS_τExectI3 CAS_τExecrI3 simp del: compE2.simps compEs2.simps)
      with True show ?thesis by auto
    next
      case False
      with exec' τ obtain pc' stk' loc' xcp'
        where e: "τExec_mover_a P t e3 h ([], xs, 0, None) (stk', loc', pc', xcp')"
        and e': "exec_move_a P t e3 h (stk', loc', pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'', loc'', pc'', xcp'')"
        and τ': "¬ τmove2 (compP2 P) h stk' e3 pc' xcp'" 
        and call: "call1 e3 = None  no_call2 e3 0  pc' = 0  stk' = []  loc' = xs  xcp' = None" by auto
      from e have "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h ([] @ [v', v1], xs, length (compE2 e1) + length (compE2 e2) + 0, None) (stk' @ [v', v1], loc', length (compE2 e1) + length (compE2 e2) + pc', xcp')" by(rule CAS_τExecrI3)
      moreover from e' have "exec_move_a P t (e1∙compareAndSwap(DF, e2, e3)) h (stk' @ [v', v1], loc', length (compE2 e1) + length (compE2 e2) + pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'' @ [v', v1], loc'', length (compE2 e1) + length (compE2 e2) + pc'', xcp'')"
        by(rule exec_move_CASI3)
      moreover from e' τ' have "¬ τmove2 (compP2 P) h (stk' @ [v', v1]) (e1∙compareAndSwap(DF, e2, e3)) (length (compE2 e1) + length (compE2 e2) + pc') xcp'"
        by(auto simp add: τinstr_stk_drop_exec_move τmove2_iff)
      moreover from red have "call1 (Val v1∙compareAndSwap(DF, Val v', e3)) = call1 e3" by auto
      moreover have "no_call2 e3 0  no_call2 (e1∙compareAndSwap(DF, e2, e3)) (length (compE2 e1) + length (compE2 e2))"
        by(auto simp add: no_call2_def)
      ultimately show ?thesis using False call by(auto simp del: split_paired_Ex call1.simps calls1.simps) blast 
    qed
    moreover from bisim'
    have "P,e1∙compareAndSwap(DF, e2, e3),h'  (Val v1∙compareAndSwap(DF, Val v', E'), xs')  ((stk'' @ [v', v1]),  loc'', length (compE2 e1) + length (compE2 e2) + pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1CAS3)
    moreover from bisim2 have "pc  length (compE2 e2)  no_call2 (e1∙compareAndSwap(DF, e2, e3)) (length (compE2 e1) + pc)"
      by(auto simp add: no_call2_def dest: bisim_Val_pc_not_Invoke bisim1_pc_length_compE2)
    ultimately show ?thesis using τ exec1 s
      apply(auto simp del: split_paired_Ex call1.simps calls1.simps split: if_split_asm split del: if_split)
      apply(blast intro: τExec_mover_trans|fastforce elim!: τExec_mover_trans simp del: split_paired_Ex call1.simps calls1.simps)+
      done
  next
    case (CAS1Null v v')
    note [simp] = v1 = Null› e' = THROW NullPointer› e2' = Val v xs' = xs ta = ε h' = h e3 = Val v'
    have τ: "¬ τmove1 P h (CompareAndSwap null D F (Val v) (Val v'))" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim2 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t e2 h (stk, loc, pc, xcp) ([v], loc, length (compE2 e2), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h (stk @ [Null], loc, length (compE2 e1) + pc, xcp) ([v] @ [Null], loc, length (compE2 e1) + length (compE2 e2), None)"
      by-(rule CAS_τExecrI2)
    hence "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h (stk @ [Null], loc, length (compE2 e1) + pc, xcp) ([] @ [v, Null], loc, length (compE2 e1) + length (compE2 e2) + 0, None)" by simp
    also from bisim3[of loc] have "τExec_mover_a P t e3 h ([], loc, 0, None) ([v'], loc, length (compE2 e3), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h ([] @ [v, Null], loc, length (compE2 e1) + length (compE2 e2) + 0, None) ([v'] @ [v, Null], loc, length (compE2 e1) + length (compE2 e2) + length (compE2 e3), None)"
      by(rule CAS_τExecrI3)
    also (rtranclp_trans)
    have "exec_move_a P t (e1∙compareAndSwap(DF, e2, e3)) h ([v', v, Null], loc, length (compE2 e1) + length (compE2 e2) + length (compE2 e3), None) ε
                                 h ([v', v, Null], loc, length (compE2 e1) + length (compE2 e2) + length (compE2 e3), addr_of_sys_xcpt NullPointer)"
      unfolding exec_move_def by-(rule exec_instr, auto simp add: is_Ref_def)
    moreover have "τmove2 (compP2 P) h [v', v, Null] (e1∙compareAndSwap(DF, e2, e3)) (length (compE2 e1) + length (compE2 e2) + length (compE2 e3)) None  False"
      by(simp add: τmove2_iff)
    moreover
    have "P, e1∙compareAndSwap(DF, e2, e3), h'  (THROW NullPointer, loc)  ([v', v, Null], loc, length (compE2 e1) + length (compE2 e2) + length (compE2 e3), addr_of_sys_xcpt NullPointer)"
      by(rule bisim1_bisims1.bisim1CASFail)
    ultimately show ?thesis using s τ by auto blast
  next
    case (Red1CASSucceed a v v')
    hence [simp]: "v1 = Addr a" "e' = true" "e2' = Val v"
      "ta = ReadMem a (CField D F) v, WriteMem a (CField D F) v'" "xs' = xs" "e3 = Val v'"
      and read: "heap_read h a (CField D F) v"
      and "write": "heap_write h a (CField D F) v' h'" by auto
    have τ: "¬ τmove1 P h (CompareAndSwap (addr a) D F (Val v) (Val v'))" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim2 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t e2 h (stk, loc, pc, xcp) ([v], loc, length (compE2 e2), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h (stk @ [Addr a], loc, length (compE2 e1) + pc, xcp) ([v] @ [Addr a], loc, length (compE2 e1) + length (compE2 e2), None)"
      by-(rule CAS_τExecrI2)
    hence "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h (stk @ [Addr a], loc, length (compE2 e1) + pc, xcp) ([] @ [v, Addr a], loc, length (compE2 e1) + length (compE2 e2) + 0, None)" by simp
    also from bisim3[of loc] have "τExec_mover_a P t e3 h ([], loc, 0, None) ([v'], loc, length (compE2 e3), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h ([] @ [v, Addr a], loc, length (compE2 e1) + length (compE2 e2) + 0, None) ([v'] @ [v, Addr a], loc, length (compE2 e1) + length (compE2 e2) + length (compE2 e3), None)"
      by(rule CAS_τExecrI3)
    also (rtranclp_trans) from read "write"
    have "exec_move_a P t (e1∙compareAndSwap(DF, e2, e3)) h ([v', v, Addr a], loc, length (compE2 e1) + length (compE2 e2) + length (compE2 e3), None)
                                  ReadMem a (CField D F) v, WriteMem a (CField D F) v' 
                                 h' ([Bool True], loc, Suc (length (compE2 e1) + length (compE2 e2) + length (compE2 e3)), None)"
      unfolding exec_move_def by-(rule exec_instr, auto simp add: compP2_def is_Ref_def)
    moreover have "τmove2 (compP2 P) h [v', v, Addr a] (e1∙compareAndSwap(DF, e2, e3)) (length (compE2 e1) + length (compE2 e2) + length (compE2 e3)) None  False"
      by(simp add: τmove2_iff)
    moreover
    have "P, e1∙compareAndSwap(DF, e2, e3), h'  (true, loc)  ([Bool True], loc, length (compE2 (e1∙compareAndSwap(DF, e2, e3))), None)"
      by(rule bisim1Val2) simp
    ultimately show ?thesis using s τ by(auto simp add: ta_upd_simps) blast
  next
    case (Red1CASFail a v'' v v')
    hence [simp]: "v1 = Addr a" "e' = false" "e2' = Val v" "h' = h"
      "ta = ReadMem a (CField D F) v''" "xs' = xs" "e3 = Val v'"
      and read: "heap_read h a (CField D F) v''" "v  v''" by auto
    have τ: "¬ τmove1 P h (CompareAndSwap (addr a) D F (Val v) (Val v'))" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim2 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t e2 h (stk, loc, pc, xcp) ([v], loc, length (compE2 e2), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h (stk @ [Addr a], loc, length (compE2 e1) + pc, xcp) ([v] @ [Addr a], loc, length (compE2 e1) + length (compE2 e2), None)"
      by-(rule CAS_τExecrI2)
    hence "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h (stk @ [Addr a], loc, length (compE2 e1) + pc, xcp) ([] @ [v, Addr a], loc, length (compE2 e1) + length (compE2 e2) + 0, None)" by simp
    also from bisim3[of loc] have "τExec_mover_a P t e3 h ([], loc, 0, None) ([v'], loc, length (compE2 e3), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h ([] @ [v, Addr a], loc, length (compE2 e1) + length (compE2 e2) + 0, None) ([v'] @ [v, Addr a], loc, length (compE2 e1) + length (compE2 e2) + length (compE2 e3), None)"
      by(rule CAS_τExecrI3)
    also (rtranclp_trans) from read 
    have "exec_move_a P t (e1∙compareAndSwap(DF, e2, e3)) h ([v', v, Addr a], loc, length (compE2 e1) + length (compE2 e2) + length (compE2 e3), None)
                                  ReadMem a (CField D F) v'' 
                                 h' ([Bool False], loc, Suc (length (compE2 e1) + length (compE2 e2) + length (compE2 e3)), None)"
      unfolding exec_move_def by-(rule exec_instr, auto simp add: compP2_def is_Ref_def)
    moreover have "τmove2 (compP2 P) h [v', v, Addr a] (e1∙compareAndSwap(DF, e2, e3)) (length (compE2 e1) + length (compE2 e2) + length (compE2 e3)) None  False"
      by(simp add: τmove2_iff)
    moreover
    have "P, e1∙compareAndSwap(DF, e2, e3), h'  (false, loc)  ([Bool False], loc, length (compE2 (e1∙compareAndSwap(DF, e2, e3))), None)"
      by(rule bisim1Val2) simp
    ultimately show ?thesis using s τ by(auto simp add: ta_upd_simps) blast
  next
    case (CAS1Throw2 ad)
    note [simp] = e2' = Throw ad ta = ε e' = Throw ad h' = h xs' = xs
    have τ: "τmove1 P h (Val v1∙compareAndSwap(DF, Throw ad, e3))" by(rule τmove1CASThrow2)
    from bisim2 have "xcp = ad  xcp = None" by(auto dest: bisim1_ThrowD)
    thus ?thesis
    proof
      assume [simp]: "xcp = ad"
      with bisim2
      have "P, e1∙compareAndSwap(DF, e2, e3), h  (Throw ad, xs)  (stk @ [v1], loc, length (compE2 e1) + pc, xcp)"
        by(auto intro: bisim1_bisims1.intros)
      thus ?thesis using τ by(fastforce)
    next
      assume [simp]: "xcp = None"
      with bisim2 obtain pc' where "τExec_mover_a P t e2 h (stk, loc, pc, None) ([Addr ad], loc, pc', ad)"
        and bisim': "P, e2, h  (Throw ad, xs)  ([Addr ad], loc, pc', ad)"
        and [simp]: "xs = loc"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h (stk @ [v1], loc, length (compE2 e1) + pc, None) ([Addr ad] @ [v1], loc, length (compE2 e1) + pc', ad)"
        by-(rule CAS_τExecrI2)
      moreover from bisim'
      have "P, e1∙compareAndSwap(DF, e2, e3), h  (Throw ad, xs)  ([Addr ad] @ [v1], loc, length (compE2 e1) +  pc', ad)"
        by(rule bisim1_bisims1.bisim1CASThrow2)
      ultimately show ?thesis using τ by auto
    qed
  next
    case (CAS1Throw3 v' ad)
    note [simp] = e2' = Val v' e3 = Throw ad ta = ε e' = Throw ad h' = h xs' = xs
    from bisim2 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t e2 h (stk, loc, pc, xcp) ([v'], loc, length (compE2 e2), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, Throw ad)) h (stk @ [v1], loc, length (compE2 e1) + pc, xcp) ([v'] @ [v1], loc, length (compE2 e1) + length (compE2 e2), None)"
      by-(rule CAS_τExecrI2)
    also have "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, Throw ad)) h ([v'] @ [v1], loc, length (compE2 e1) + length (compE2 e2), None) ([Addr ad, v', v1], loc, Suc (length (compE2 e1) + length (compE2 e2)), ad)"
      by(rule τExecr2step)(auto simp add: exec_move_def exec_meth_instr τmove2_iff τmove1.simps τmoves1.simps)
    also (rtranclp_trans)
    have "P,e1∙compareAndSwap(DF, e2, Throw ad),h  (Throw ad, loc)  ([Addr ad] @ [v', v1], loc, (length (compE2 e1) + length (compE2 e2) + length (compE2 (addr ad))), ad)"
      by(rule bisim1CASThrow3[OF bisim1Throw2])
    moreover have "τmove1 P h (CompareAndSwap (Val v1) D F (Val v') (Throw ad))" by(auto intro: τmove1CASThrow3)
    ultimately show ?thesis using s by auto
  qed auto
next
  case (bisim1CAS3 e3 n e3' xs stk loc pc xcp e1 e2 D F v v')
  note IH3 = bisim1CAS3.IH(2)
  note bisim3 = P,e3,h  (e3', xs)  (stk, loc, pc, xcp)
  note bsok = ‹bsok (e1∙compareAndSwap(DF, e2, e3)) n
  from ‹True,P,t ⊢1 Val v∙compareAndSwap(DF, Val v', e3'),(h, xs) -ta e',(h', xs') show ?case
  proof cases
    case (CAS1Red3 E')
    note [simp] = e' = Val v∙compareAndSwap(DF, Val v', E')
      and red = ‹True,P,t ⊢1 e3',(h, xs) -ta E',(h', xs')
    from red have τ: "τmove1 P h (Val v∙compareAndSwap(DF, Val v', e3')) = τmove1 P h e3'" by(auto simp add: τmove1.simps τmoves1.simps)
    from IH3[OF red] bsok obtain pc'' stk'' loc'' xcp''
      where bisim': "P,e3,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and exec': "?exec ta e3 e3' E' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    have "no_call2 e3 pc  no_call2 (e1∙compareAndSwap(DF, e2, e3)) (length (compE2 e1) + length (compE2 e2) +  pc)" 
      by(auto simp add: no_call2_def)
    hence "?exec ta (e1∙compareAndSwap(DF, e2, e3)) (Val v∙compareAndSwap(DF, Val v', e3')) (Val v∙compareAndSwap(DF, Val v', E')) h (stk @ [v', v]) loc (length (compE2 e1) + length (compE2 e2) + pc) xcp h' (length (compE2 e1) + length (compE2 e2) + pc'') (stk'' @ [v', v]) loc'' xcp''"
      using exec' τ
      apply(cases "τmove1 P h (Val v∙compareAndSwap(DF, Val v', e3'))")
      apply(auto)
      apply(blast intro: CAS_τExecrI3 CAS_τExectI3 exec_move_CASI3)
      apply(blast intro: CAS_τExecrI3 CAS_τExectI3 exec_move_CASI3)
      apply(rule exI conjI CAS_τExecrI3 exec_move_CASI3|assumption)+
      apply(fastforce simp add: τinstr_stk_drop_exec_move τmove2_iff split: if_split_asm)
      apply(rule exI conjI CAS_τExecrI3 exec_move_CASI3|assumption)+
      apply(fastforce simp add: τinstr_stk_drop_exec_move τmove2_iff split: if_split_asm)
      apply(rule exI conjI CAS_τExecrI3 exec_move_CASI3 rtranclp.rtrancl_refl|assumption)+
      apply(fastforce simp add: τinstr_stk_drop_exec_move τmove2_iff split: if_split_asm)+
      done
    moreover from bisim'
    have "P,e1∙compareAndSwap(DF, e2, e3),h'  (Val v∙compareAndSwap(DF, Val v', E'), xs')  (stk''@[v',v], loc'', length (compE2 e1) + length (compE2 e2) + pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1CAS3)
    ultimately show ?thesis using τ by auto blast+
  next
    case (CAS1Null v'')
    note [simp] = v = Null› e' = THROW NullPointer› xs' = xs ta = ε h' = h e3' = Val v''
    have τ: "¬ τmove1 P h (CompareAndSwap null D F (Val v') (Val v''))" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim3 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t e3 h (stk, loc, pc, xcp) ([v''], loc, length (compE2 e3), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h (stk @ [v', Null], loc, length (compE2 e1) + length (compE2 e2) + pc, xcp) ([v''] @ [v', Null], loc, length (compE2 e1) + length (compE2 e2) + length (compE2 e3), None)"
      by-(rule CAS_τExecrI3)
    moreover
    have "exec_move_a P t (e1∙compareAndSwap(DF, e2, e3)) h ([v'', v', Null], loc, length (compE2 e1) + length (compE2 e2) + length (compE2 e3), None) ε
                                 h ([v'', v', Null], loc, length (compE2 e1) + length (compE2 e2) + length (compE2 e3), addr_of_sys_xcpt NullPointer)"
      unfolding exec_move_def by-(rule exec_instr, auto simp add: is_Ref_def)
    moreover have "τmove2 (compP2 P) h [v'', v', Null] (e1∙compareAndSwap(DF, e2, e3)) (length (compE2 e1) + length (compE2 e2) + length (compE2 e3)) None  False"
      by(simp add: τmove2_iff)
    moreover
    have "P, e1∙compareAndSwap(DF, e2, e3), h'  (THROW NullPointer, loc)  ([v'', v', Null], loc, length (compE2 e1) + length (compE2 e2) + length (compE2 e3), addr_of_sys_xcpt NullPointer)"
      by(rule bisim1_bisims1.bisim1CASFail)
    ultimately show ?thesis using s τ by auto blast
  next
    case (Red1CASSucceed a v'')
    hence [simp]: "v = Addr a" "e' = true" "e3' = Val v''"
      "ta = ReadMem a (CField D F) v', WriteMem a (CField D F) v''" "xs' = xs" 
      and read: "heap_read h a (CField D F) v'"
      and "write": "heap_write h a (CField D F) v'' h'" by auto
    have τ: "¬ τmove1 P h (CompareAndSwap (addr a) D F (Val v') (Val v''))" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim3 have s: "xcp = None" "xs = loc"
      and exec1: "τExec_mover_a P t e3 h (stk, loc, pc, xcp) ([v''], loc, length (compE2 e3), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h (stk @ [v', Addr a], loc, length (compE2 e1) + length (compE2 e2) + pc, xcp) ([v''] @ [v', Addr a], loc, length (compE2 e1) + length (compE2 e2) + length (compE2 e3), None)"
      by-(rule CAS_τExecrI3)
    moreover from read "write"
    have "exec_move_a P t (e1∙compareAndSwap(DF, e2, e3)) h ([v'', v', Addr a], loc, length (compE2 e1) + length (compE2 e2) + length (compE2 e3), None) 
                                 ReadMem a (CField D F) v', WriteMem a (CField D F) v''
                                 h' ([Bool True], loc, Suc (length (compE2 e1) + length (compE2 e2) + length (compE2 e3)), None)"
     unfolding exec_move_def by-(rule exec_instr, auto simp add: compP2_def is_Ref_def)
    moreover have "τmove2 (compP2 P) h [v'', v', Addr a] (e1∙compareAndSwap(DF, e2, e3)) (length (compE2 e1) + length (compE2 e2) + length (compE2 e3)) None  False"
      by(simp add: τmove2_iff)
    moreover 
    have "P, e1∙compareAndSwap(DF, e2, e3), h'  (true, loc)  ([Bool True], loc, length (compE2 (e1∙compareAndSwap(DF, e2, e3))), None)"
      by(rule bisim1Val2) simp
    ultimately show ?thesis using s τ by(auto simp add: ta_upd_simps ac_simps) blast
  next
    case (Red1CASFail a v'' v''')
    hence [simp]: "v = Addr a" "e' = false" "e3' = Val v'''" "h' = h"
      "ta = ReadMem a (CField D F) v''" "xs' = xs"
      and read: "heap_read h a (CField D F) v''" "v'  v''" by auto
    have τ: "¬ τmove1 P h (CompareAndSwap (addr a) D F (Val v') (Val v'''))" by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim3 have s: "xcp = None" "xs = loc"
      and exec1: "τExec_mover_a P t e3 h (stk, loc, pc, xcp) ([v'''], loc, length (compE2 e3), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h (stk @ [v', Addr a], loc, length (compE2 e1) + length (compE2 e2) + pc, xcp) ([v'''] @ [v', Addr a], loc, length (compE2 e1) + length (compE2 e2) + length (compE2 e3), None)"
      by-(rule CAS_τExecrI3)
    moreover from read
    have "exec_move_a P t (e1∙compareAndSwap(DF, e2, e3)) h ([v''', v', Addr a], loc, length (compE2 e1) + length (compE2 e2) + length (compE2 e3), None) 
                                 ReadMem a (CField D F) v''
                                 h' ([Bool False], loc, Suc (length (compE2 e1) + length (compE2 e2) + length (compE2 e3)), None)"
     unfolding exec_move_def by-(rule exec_instr, auto simp add: compP2_def is_Ref_def)
    moreover have "τmove2 (compP2 P) h [v''', v', Addr a] (e1∙compareAndSwap(DF, e2, e3)) (length (compE2 e1) + length (compE2 e2) + length (compE2 e3)) None  False"
      by(simp add: τmove2_iff)
    moreover 
    have "P, e1∙compareAndSwap(DF, e2, e3), h'  (false, loc)  ([Bool False], loc, length (compE2 (e1∙compareAndSwap(DF, e2, e3))), None)"
      by(rule bisim1Val2) simp
    ultimately show ?thesis using s τ by(auto simp add: ta_upd_simps ac_simps) blast
  next
    case (CAS1Throw3 A)
    note [simp] = e3' = Throw A ta = ε e' = Throw A h' = h xs' = xs
    have τ: "τmove1 P h (CompareAndSwap (Val v) D F (Val v') (Throw A))" by(rule τmove1CASThrow3)
    from bisim3 have "xcp = A  xcp = None" by(auto dest: bisim1_ThrowD)
    thus ?thesis
    proof
      assume [simp]: "xcp = A"
      with bisim3
      have "P, e1∙compareAndSwap(DF, e2, e3), h  (Throw A, xs)  (stk @ [v', v], loc, length (compE2 e1) + length (compE2 e2) + pc, xcp)"
        by(auto intro: bisim1_bisims1.intros)
      thus ?thesis using τ by(fastforce)
    next
      assume [simp]: "xcp = None"
      with bisim3 obtain pc' where "τExec_mover_a P t e3 h (stk, loc, pc, None) ([Addr A], loc, pc', A)"
        and bisim': "P, e3, h  (Throw A, xs)  ([Addr A], loc, pc', A)"
        and [simp]: "xs = loc"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t (e1∙compareAndSwap(DF, e2, e3)) h (stk @ [v', v], loc, length (compE2 e1) + length (compE2 e2) + pc, None) ([Addr A] @ [v', v], loc, length (compE2 e1) + length (compE2 e2) + pc', A)"
        by-(rule CAS_τExecrI3)
      moreover from bisim'
      have "P, e1∙compareAndSwap(DF, e2, e3), h  (Throw A, xs)  ([Addr A] @ [v', v], loc, length (compE2 e1) +  length (compE2 e2) + pc', A)"
        by(rule bisim1_bisims1.bisim1CASThrow3)
      ultimately show ?thesis using τ by auto
    qed
  qed auto
next
  case bisim1CASThrow1 thus ?case by auto
next
  case bisim1CASThrow2 thus ?case by auto
next
  case bisim1CASThrow3 thus ?case by auto
next
  case bisim1CASFail thus ?case by auto
next
  case (bisim1CallParams ps n ps' xs stk loc pc xcp obj M' v)
  note IHparam = bisim1CallParams.IH(2)
  note bisim1 = xs. P,obj,h  (obj, xs)  ([], xs, 0, None)
  note bisim2 = P,ps,h  (ps', xs) [↔] (stk, loc, pc, xcp)
  note red = ‹True,P,t ⊢1 Val vM'(ps'),(h, xs) -ta e',(h', xs')
  note bsok = ‹bsok (objM'(ps)) n
  from bisim2 ps  [] have ps': "ps'  []" by(auto dest: bisims1_lengthD)
  from red show ?case
  proof cases
    case (Call1Params es')
    note [simp] = e' = Val vM'(es')
      and red = ‹True,P,t ⊢1 ps', (h, xs) [-ta→] es', (h', xs')
    from red have τ: "τmove1 P h (Val vM'(ps')) = τmoves1 P h ps'" by(auto simp add: τmove1.simps τmoves1.simps)
    from IHparam[OF red] bsok obtain pc'' stk'' loc'' xcp''
      where bisim': "P,ps,h'  (es', xs') [↔] (stk'', loc'', pc'', xcp'')"
      and exec': "?execs ta ps ps' es' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    have "?exec ta (objM'(ps)) (Val vM'(ps')) (Val vM'(es')) h (stk @ [v]) loc (length (compE2 obj) + pc) xcp  h' (length (compE2 obj) + pc'') (stk'' @ [v]) loc'' xcp''"
    proof(cases "τmove1 P h (Val vM'(ps'))")
      case True
      with exec' τ show ?thesis by (auto intro: Call_τExecrI2 Call_τExectI2)
    next
      case False
      with exec' τ obtain pc' stk' loc' xcp'
        where e: "τExec_movesr_a P t ps h (stk, loc, pc, xcp) (stk', loc', pc', xcp')"
        and e': "exec_moves_a P t ps h (stk', loc', pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'', loc'', pc'', xcp'')"
        and τ': "¬ τmoves2 (compP2 P) h stk' ps pc' xcp'" 
        and call: "(calls1 ps' = None  no_calls2 ps pc  pc' = pc  stk' = stk  loc' = loc  xcp' = xcp)" by auto
      from e have "τExec_mover_a P t (objM'(ps)) h (stk @ [v], loc, length (compE2 obj) + pc, xcp) (stk' @ [v], loc', length (compE2 obj) + pc', xcp')" by(rule Call_τExecrI2)
      moreover from e' have "exec_move_a P t (objM'(ps)) h (stk' @ [v], loc', length (compE2 obj) + pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'' @ [v], loc'', length (compE2 obj) + pc'', xcp'')"
        by(rule exec_move_CallI2)
      moreover from τ' e' have "τmove2 (compP2 P) h (stk' @ [v]) (objM'(ps)) (length (compE2 obj) + pc') xcp'  False"
        by(auto simp add: τmove2_iff τmoves2_iff τinstr_stk_drop_exec_moves split: if_split_asm)
      moreover from red have "call1 (Val vM'(ps')) = calls1 ps'" by(auto simp add: is_vals_conv)
      moreover from red have "no_calls2 ps pc  no_call2 (objM'(ps)) (length (compE2 obj) + pc)  pc = length (compEs2 ps)"
        by(auto simp add: no_call2_def no_calls2_def)
      ultimately show ?thesis using False call e
        by(auto simp del: split_paired_Ex call1.simps calls1.simps) blast+
    qed
    moreover from bisim'
    have "P,objM'(ps),h'  (Val vM'(es'), xs')  ((stk'' @ [v]), loc'', length (compE2 obj) + pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1CallParams)
    ultimately show ?thesis using τ
      by(auto simp del: call1.simps calls1.simps split: if_split_asm split del: if_split) blast+
  next
    case (Red1CallNull vs)
    note [simp] = h' = h xs' = xs ta = ε v = Null› ps' = map Val vs e' = THROW NullPointer›
    from bisim2 have length: "length ps = length vs" by(auto dest: bisims1_lengthD)
    have "xs = loc  xcp = None  τExec_movesr_a P t ps h (stk, loc, pc, xcp) (rev vs, loc, length (compEs2 ps), None)"
    proof(cases "pc < length (compEs2 ps)")
      case True
      with bisim2 show ?thesis by(auto dest: bisims1_Val_τExec_moves)
    next
      case False
      with bisim2 have "pc = length (compEs2 ps)"
        by(auto dest: bisims1_pc_length_compEs2)
      with bisim2 show ?thesis by(auto dest: bisims1_Val_length_compEs2D)
    qed
    hence s: "xs = loc" "xcp = None"
      and "τExec_movesr_a P t ps h (stk, loc, pc, xcp) (rev vs, loc, length (compEs2 ps), None)" by auto
    hence "τExec_mover_a P t (objM'(ps)) h (stk @ [Null], loc, length (compE2 obj) + pc, xcp) (rev vs @ [Null], loc, length (compE2 obj) + length (compEs2 ps), None)"
      by -(rule Call_τExecrI2)
    also {
      from length have "exec_move_a P t (objM'(ps)) h (rev vs @ [Null], loc, length (compE2 obj) + length (compEs2 ps), None) ε h (rev vs @ [Null], loc, length (compE2 obj) + length (compEs2 ps), addr_of_sys_xcpt NullPointer)"
        unfolding exec_move_def by(cases ps)(auto intro: exec_instr)
      moreover have "τmove2 P h (rev vs @ [Null]) (objM'(ps)) (length (compE2 obj) + length (compEs2 ps)) None"
        using length by(simp add: τmove2_iff)
      ultimately have "τExec_movet_a P t (objM'(ps)) h (rev vs @ [Null], loc, length (compE2 obj) + length (compEs2 ps), None) (rev vs @ [Null], loc, length (compE2 obj) + length (compEs2 ps), addr_of_sys_xcpt NullPointer)"
        by(auto intro: τexec_moveI) }
    also have "τmove1 P h (nullM'(map Val vs))"
      by(auto simp add: τmove1.simps τmoves1.simps map_eq_append_conv)
    moreover
    from length have "P,objM'(ps),h  (THROW NullPointer, loc)  ((rev vs @ [Null]), loc, length (compE2 obj) + length (compEs2 ps), addr_of_sys_xcpt NullPointer)"
      by-(rule bisim1CallThrow, simp)
    ultimately show ?thesis using s by auto
  next
    case (Call1ThrowParams vs a es')
    note [simp] =  ta = ε e' = Throw a ps' = map Val vs @ Throw a # es' h' = h xs' = xs
    have τ: "τmove1 P h (Val vM'(map Val vs @ Throw a # es'))" by(rule τmove1CallThrowParams)
    from bisim2 have [simp]: "xs = loc" and "xcp = a  xcp = None" by(auto dest: bisims1_ThrowD)
    from xcp = a  xcp = None› show ?thesis
    proof
      assume [simp]: "xcp = a"
      with bisim2
      have "P,objM'(ps),h  (Throw a, loc)  (stk @ [v], loc, length (compE2 obj) + pc, a)"
        by -(rule bisim1CallThrowParams, auto)
      thus ?thesis using τ by(fastforce)
    next
      assume [simp]: "xcp = None"
      with bisim2 obtain pc'
        where exec: "τExec_movesr_a P t ps h (stk, loc, pc, None) (Addr a # rev vs, loc, pc', a)"
        and bisim': "P, ps, h  (map Val vs @ Throw a # es', loc) [↔] (Addr a # rev vs, loc, pc', a)"
        by(auto dest: bisims1_Throw_τExec_movesr)
      from bisim'
      have "P,objM'(ps),h  (Throw a, loc)  ((Addr a # rev vs) @ [v], loc, length (compE2 obj) + pc', a)"
        by(rule bisim1CallThrowParams)
      with Call_τExecrI2[OF exec, of obj M' v] τ
      show ?thesis by auto
    qed
  next
    case (Red1CallExternal a Ta Ts Tr D vs va H')
    hence [simp]: "v = Addr a" "ps' = map Val vs" "e' = extRet2J (addr aM'(map Val vs)) va" "H' = h'" "xs' = xs"
      and Ta: "typeof_addr h a = Ta"
      and iec: "P  class_type_of Ta sees M': TsTr = Native in D"
      and redex: "P,t  aM'(vs),h -ta→ext va,h'" by auto
    from bisim2 have [simp]: "xs = loc" by(auto dest: bisims_Val_loc_eq_xcp_None)
    moreover from bisim2 have "length ps = length ps'"
      by(rule bisims1_lengthD)
    hence τ: "τmove1 P h (addr aM'(map Val vs) :: 'addr expr1) = τmove2 (compP2 P) h (rev vs @ [Addr a]) (objM'(ps)) (length (compE2 obj) + length (compEs2 ps)) None"
      using Ta iec by(auto simp add: τmove1.simps τmoves1.simps map_eq_append_conv τmove2_iff compP2_def)
    obtain s: "xcp = None" "xs = loc"
      and "τExec_movesr_a P t ps h (stk, loc, pc, xcp) (rev vs, loc, length (compEs2 ps), None)"
    proof(cases "pc < length (compEs2 ps)")
      case True
      with bisim2 show ?thesis by(auto dest: bisims1_Val_τExec_moves intro: that)
    next
      case False
      with bisim2 have "pc = length (compEs2 ps)" by(auto dest: bisims1_pc_length_compEs2)
      with bisim2 show ?thesis by -(rule that, auto dest!: bisims1_pc_length_compEs2D)
    qed
    from Call_τExecrI2[OF this(3), of obj M' v]
    have "τExec_mover_a P t (objM'(ps)) h (stk @ [Addr a], loc, length (compE2 obj) + pc, xcp) (rev vs @ [Addr a], loc, length (compE2 obj) + length (compEs2 ps), None)" by simp
    moreover from bisim2 have "pc  length (compEs2 ps)" by(rule bisims1_pc_length_compEs2)
    hence "no_call2 (objM'(ps)) (length (compE2 obj) + pc)  pc = length (compEs2 ps)"
      using bisim2 by(auto simp add: no_call2_def neq_Nil_conv dest: bisims_Val_pc_not_Invoke)
    moreover { 
      assume "pc = length (compEs2 ps)"
      with ‹τExec_movesr_a P t ps h (stk, loc, pc, xcp) (rev vs, loc, length (compEs2 ps), None)
      have "stk = rev vs" "xcp = None" by auto }
    moreover
    let ?ret = "extRet2JVM (length ps) h' (rev vs @ [Addr a]) loc undefined undefined (length (compE2 obj) + length (compEs2 ps)) [] va"
    let ?stk' = "fst (hd (snd (snd ?ret)))"
    let ?xcp' = "fst ?ret"
    let ?pc' = "snd (snd (snd (snd (hd (snd (snd ?ret))))))"
    from bisim2 have [simp]: "length ps = length vs" by(auto dest: bisims1_lengthD)
    from redex have redex': "(ta, va, h')  red_external_aggr (compP2 P) t a M' vs h"
      by -(rule red_external_imp_red_external_aggr, simp add: compP2_def)
    with Ta iec
    have "exec_move_a P t (objM'(ps)) h (rev vs @ [Addr a], loc, length (compE2 obj) + length (compEs2 ps), None) (extTA2JVM (compP2 P) ta) h' (?stk', loc, ?pc', ?xcp')"
      unfolding exec_move_def
      by -(rule exec_instr,cases va,(force simp add: compP2_def is_Ref_def simp del: split_paired_Ex intro: external_WT'.intros)+)
    moreover have "P,objM'(ps),h'  (extRet2J1 (addr aM'(map Val vs)) va, loc)  (?stk', loc, ?pc', ?xcp')"
    proof(cases va)
      case (RetVal v)
      have "P,objM'(ps),h'  (Val v, loc)  ([v], loc, length (compE2 (objM'(ps))), None)"
        by(rule bisim1Val2) simp
      thus ?thesis unfolding RetVal by simp
    next
      case (RetExc ad) thus ?thesis by(auto intro: bisim1CallThrow)
    next
      case RetStaySame
      from bisims1_map_Val_append[OF bisims1Nil, of ps vs P h' loc]
      have "P,ps,h'  (map Val vs, loc) [↔] (rev vs, loc, length (compEs2 ps), None)" by simp
      hence "P,objM'(ps),h'  (addr aM'(map Val vs), loc)  (rev vs @ [Addr a], loc, length (compE2 obj) + length (compEs2 ps), None)"
        by(rule bisim1_bisims1.bisim1CallParams)
      thus ?thesis using RetStaySame by simp
    qed
    moreover from redex Ta iec
    have "τmove1 P h (addr aM'(map Val vs) :: 'addr expr1)  ta = ε  h' = h"
      by(fastforce simp add: τmove1.simps τmoves1.simps map_eq_append_conv τexternal'_def τexternal_def dest: τexternal'_red_external_TA_empty τexternal'_red_external_heap_unchanged sees_method_fun)
    ultimately show ?thesis using τ
      apply(cases "τmove1 P h (addr aM'(map Val vs) :: 'addr expr1)")
      apply(auto simp del: split_paired_Ex simp add: compP2_def)
      apply(blast intro: rtranclp.rtrancl_into_rtrancl rtranclp_into_tranclp1 τexec_moveI)+
      done
  qed(insert ps', auto)
next
  case bisim1CallThrowObj thus ?case by fastforce
next
  case bisim1CallThrowParams thus ?case by auto
next
  case bisim1CallThrow thus ?case by fastforce
next
  case (bisim1BlockSome1 e n V Ty v xs e')
  from ‹True,P,t ⊢1 {V:Ty=v; e},(h, xs) -ta e',(h', xs') show ?case
  proof(cases)
    case Block1Some
    note [simp] = ta = ε e' = {V:Ty=None; e} h' = h xs' = xs[V := v]
      and len = V < length xs
    from len have exec: "τExec_movet_a P t {V:Ty=v; e} h ([], xs, 0, None) ([], xs[V := v], Suc (Suc 0), None)"
      by-(rule τExect2step, auto intro: exec_instr simp add: exec_move_def τmove2_iff)
    moreover have "P,{V:Ty=v; e},h  ({V:Ty=None; e}, xs[V := v])  ([], xs[V := v], Suc (Suc 0), None)"
      by(rule bisim1BlockSome4)(rule bisim1_refl)
    moreover have "τmove1 P h {V:Ty=v; e}" by(auto intro: τmove1BlockSome)
    ultimately show ?thesis by auto
  qed
next
  case (bisim1BlockSome2 e n V Ty v xs)
  from ‹True,P,t ⊢1 {V:Ty=v; e},(h, xs) -ta e',(h', xs') show ?case
  proof(cases)
    case Block1Some
    note [simp] = ta = ε e' = {V:Ty=None; e} h' = h xs' = xs[V := v]
      and len = V < length xs
    from len have exec: "τExec_movet_a P t {V:Ty=v; e} h ([v], xs, Suc 0, None) ([], xs[V := v], Suc (Suc 0), None)"
      by-(rule τExect1step, auto intro: exec_instr τmove2BlockSome2 simp: exec_move_def)
    moreover have "P,{V:Ty=v; e},h  ({V:Ty=None; e}, xs[V := v])  ([], xs[V := v], Suc (Suc 0), None)"
      by(rule bisim1BlockSome4)(rule bisim1_refl)
    moreover have "τmove1 P h {V:Ty=v; e}" by(auto intro: τmove1BlockSome)
    ultimately show ?thesis by auto
  qed
next
  case (bisim1BlockSome4 E n e xs stk loc pc xcp V Ty v)
  note IH = bisim1BlockSome4.IH(2)
  note bisim = P,E,h  (e, xs)  (stk, loc, pc, xcp)
  note bsok = ‹bsok {V:Ty=v; E} n
  hence [simp]: "n = V" by simp
  from ‹True,P,t ⊢1 {V:Ty=None; e},(h, xs) -ta e',(h', xs') show ?case
  proof cases
    case (Block1Red E')
    note [simp] = e' = {V:Ty=None; E'}
      and red = ‹True,P,t ⊢1 e,(h, xs) -ta E',(h', xs')
    from red have τ: "τmove1 P h {V:Ty=None; e} = τmove1 P h e" by(auto simp add: τmove1.simps τmoves1.simps)
    from IH[OF red] bsok obtain pc'' stk'' loc'' xcp''
      where bisim': "P,E,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and exec': "?exec ta E e E' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    have "no_call2 E pc  no_call2 ({V:Ty=v; E}) (Suc (Suc pc))" by(auto simp add: no_call2_def)
    hence "?exec ta {V:Ty=v; E} {V:Ty=None; e} {V:Ty=None; E'} h stk loc (Suc (Suc pc)) xcp h' (Suc (Suc pc'')) stk'' loc'' xcp''"
      using exec' τ
      by(cases "τmove1 P h {V:Ty=None; e}")(auto, (blast intro: exec_move_BlockSomeI Block_τExecrI_Some Block_τExectI_Some)+)
    with bisim' τ show ?thesis by auto(blast intro: bisim1_bisims1.bisim1BlockSome4)+
  next
    case (Red1Block u)
    note [simp] = e = Val u ta = ε e' = Val u h' = h xs' = xs
    have "τmove1 P h {V:Ty=None; Val u}" by(rule τmove1BlockRed)
    moreover from bisim have [simp]: "xcp = None" "loc = xs"
      and exec: "τExec_mover_a P t E h (stk, loc, pc, xcp) ([u], loc, length (compE2 E), None)" by(auto dest: bisim1Val2D1)
    moreover
    have "P,{V:Ty=v; E},h  (Val u, xs)  ([u], xs, length (compE2 {V:Ty=v; E}), None)"
      by(rule bisim1Val2) simp
    ultimately show ?thesis by(fastforce elim!: Block_τExecrI_Some)
  next
    case (Block1Throw a)
    note [simp] = e = Throw a ta = ε e' = Throw a h' = h xs' = xs
    have τ: "τmove1 P h {V:Ty=None; e}" by(auto intro: τmove1BlockThrow)
    from bisim have "xcp = a  xcp = None" by(auto dest: bisim1_ThrowD)
    thus ?thesis
    proof
      assume [simp]: "xcp = a"
      with bisim have "P, {V:Ty=v; E}, h  (Throw a, xs)  (stk, loc, Suc (Suc pc), xcp)"
        by(auto intro: bisim1BlockThrowSome)
      thus ?thesis using τ by(fastforce)
    next
      assume [simp]: "xcp = None"
      with bisim obtain pc'
        where "τExec_mover_a P t E h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        and bisim': "P, E, h  (Throw a, xs)  ([Addr a], loc, pc', a)" and [simp]: "xs = loc"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t {V:Ty=v; E} h (stk, loc, Suc (Suc pc), None) ([Addr a], loc, Suc (Suc pc'), a)"
        by(auto intro: Block_τExecrI_Some)
      moreover from bisim' have "P, {V:Ty=v; E}, h  (Throw a, xs)  ([Addr a], loc, Suc (Suc pc'), a)"
        by(auto intro: bisim1_bisims1.bisim1BlockThrowSome)
      ultimately show ?thesis using τ by auto
    qed
  qed
next
  case bisim1BlockThrowSome thus ?case by auto
next
  case (bisim1BlockNone E n e xs stk loc pc xcp V Ty)
  note IH = bisim1BlockNone.IH(2)
  note bisim = P,E,h  (e, xs)  (stk, loc, pc, xcp)
  note bsok = ‹bsok {V:Ty=None; E} n
  hence [simp]: "n = V" by simp
  from ‹True,P,t ⊢1 {V:Ty=None; e},(h, xs) -ta e',(h', xs') show ?case
  proof cases
    case (Block1Red E')
    note [simp] = e' = {V:Ty=None; E'}
      and red = ‹True,P,t ⊢1 e,(h, xs) -ta E',(h', xs')
    from red have τ: "τmove1 P h {V:Ty=None; e} = τmove1 P h e" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover have "call1 ({V:Ty=None; e}) = call1 e" by auto
    moreover from IH[OF red] bsok
    obtain pc'' stk'' loc'' xcp'' where bisim: "P,E,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and redo: "?exec ta E e E' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    from bisim
    have "P,{V:Ty=None; E},h'  ({V:Ty=None; E'}, xs')  (stk'', loc'', pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1BlockNone)
    moreover { 
      assume "no_call2 E pc"
      hence "no_call2 {V:Ty=None; E} pc" by(auto simp add: no_call2_def) }
    ultimately show ?thesis using redo
      by(auto simp add: exec_move_BlockNone simp del: call1.simps calls1.simps split: if_split_asm split del: if_split)(blast intro: Block_τExecrI_None Block_τExectI_None)+
  next
    case (Red1Block u)
    note [simp] = e = Val u ta = ε e' = Val u h' = h xs' = xs
    have "τmove1 P h {V:Ty=None; Val u}" by(rule τmove1BlockRed)
    moreover from bisim have [simp]: "xcp = None" "loc = xs"
      and exec: "τExec_mover_a P t E h (stk, loc, pc, xcp) ([u], loc, length (compE2 E), None)" by(auto dest: bisim1Val2D1)
    moreover
    have "P,{V:Ty=None; E},h  (Val u, xs)  ([u], xs, length (compE2 {V:Ty=None; E}), None)"
      by(rule bisim1Val2) simp
    ultimately show ?thesis by(fastforce intro: Block_τExecrI_None)
  next
    case (Block1Throw a)
    note [simp] = e = Throw a ta = ε e' = Throw a h' = h xs' = xs
    have τ: "τmove1 P h {V:Ty=None; e}" by(auto intro: τmove1BlockThrow)
    from bisim have "xcp = a  xcp = None" by(auto dest: bisim1_ThrowD)
    thus ?thesis
    proof
      assume [simp]: "xcp = a"
      with bisim have "P, {V:Ty=None; E}, h  (Throw a, xs)  (stk, loc, pc, xcp)"
        by(auto intro: bisim1BlockThrowNone)
      thus ?thesis using τ by(fastforce)
    next
      assume [simp]: "xcp = None"
      with bisim obtain pc'
        where "τExec_mover_a P t E h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        and bisim': "P, E, h  (Throw a, xs)  ([Addr a], loc, pc', a)" and [simp]: "xs = loc"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t {V:Ty=None; E} h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        by(auto intro: Block_τExecrI_None)
      moreover from bisim' have "P, {V:Ty=None; E}, h  (Throw a, xs)  ([Addr a], loc, pc', a)"
        by(auto intro: bisim1_bisims1.bisim1BlockThrowNone)
      ultimately show ?thesis using τ by auto
    qed
  qed
next
  case bisim1BlockThrowNone thus ?case by auto
next
  case (bisim1Sync1 e1 n e1' xs stk loc pc xcp e2 V)
  note IH = bisim1Sync1.IH(2)
  note bisim1 = P,e1,h  (e1', xs)  (stk, loc, pc, xcp)
  note bisim2 = xs. P,e2,h  (e2, xs)  ([], xs, 0, None)
  note red = ‹True,P,t ⊢1 syncV (e1') e2,(h, xs) -ta e',(h', xs')
  note bsok = ‹bsok (syncV (e1) e2) n
  hence [simp]: "n = V" by simp
  from red show ?case
  proof cases
    case (Synchronized1Red1 E1')
    note [simp] = e' = syncV (E1') e2
      and red = ‹True,P,t ⊢1 e1', (h, xs) -ta E1', (h', xs')
    from red have τ: "τmove1 P h (syncV (e1') e2) = τmove1 P h e1'" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover have "call1 (syncV (e1') e2) = call1 e1'" by auto
    moreover from IH[OF red] bsok
    obtain pc'' stk'' loc'' xcp'' where bisim: "P,e1,h'  (E1', xs')  (stk'', loc'', pc'', xcp'')"
      and redo: "?exec ta e1 e1' E1' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    from bisim
    have "P,syncV (e1) e2,h'  (syncV (E1') e2, xs')  (stk'', loc'', pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1Sync1)
    moreover { 
      assume "no_call2 e1 pc"
      hence "no_call2 (syncV (e1) e2) pc" by(auto simp add: no_call2_def) }
    ultimately show ?thesis using redo
      by(auto simp del: call1.simps calls1.simps split: if_split_asm split del: if_split)(blast intro: Sync_τExecrI Sync_τExectI exec_move_SyncI1)+
  next
    case Synchronized1Null
    note [simp] = e1' = null› e' = THROW NullPointer› ta = ε h' = h xs' = xs[V := Null] 
      and V = V < length xs
    from bisim1 have [simp]: "xcp = None" "xs = loc"
      and exec: "τExec_mover_a P t e1 h (stk, loc, pc, xcp) ([Null], loc, length (compE2 e1), None)"
      by(auto dest: bisim1Val2D1)
    from Sync_τExecrI[OF exec]
    have "τExec_mover_a P t (syncV (e1) e2) h (stk, loc, pc, xcp) ([Null], loc, length (compE2 e1), None)" by simp
    also from V
    have "τExec_mover_a P t (syncV (e1) e2) h ([Null], loc, length (compE2 e1), None) ([Null], loc[V := Null], Suc (Suc (length (compE2 e1))), None)"
      by -(rule τExecr2step,auto intro: exec_instr τmove2_τmoves2.intros simp add: exec_move_def)
    also (rtranclp_trans)
    have "exec_move_a P t (syncV (e1) e2) h ([Null], loc[V := Null], Suc (Suc (length (compE2 e1))), None) ε
                        h ([Null], loc[V := Null], Suc (Suc (length (compE2 e1))), addr_of_sys_xcpt NullPointer)"
      unfolding exec_move_def by(rule exec_instr) auto
    moreover have "¬ τmove2 (compP2 P) h [Null] (syncV (e1) e2) (Suc (Suc (length (compE2 e1)))) None"
      by(simp add: τmove2_iff)
    moreover
    have "P,syncV (e1) e2,h  (THROW NullPointer, loc[V := Null])  ([Null], (loc[V := Null]), Suc (Suc (length (compE2 e1))), addr_of_sys_xcpt NullPointer)"
      by(rule bisim1Sync11)
    moreover have "¬ τmove1 P h (syncV (null) e2)" by(auto simp add: τmove1.simps τmoves1.simps)
    ultimately show ?thesis by auto blast
  next
    case (Lock1Synchronized a)
    note [simp] = e1' = addr a ta = Locka, SyncLock a e' = insyncV (a) e2 h' = h xs' = xs[V := Addr a] 
      and V = V < length xs
    from bisim1 have [simp]: "xcp = None" "xs = loc"
      and exec: "τExec_mover_a P t e1 h (stk, loc, pc, xcp) ([Addr a], loc, length (compE2 e1), None)"
      by(auto dest: bisim1Val2D1)
    from Sync_τExecrI[OF exec]
    have "τExec_mover_a P t (syncV (e1) e2) h (stk, loc, pc, xcp) ([Addr a], loc, length (compE2 e1), None)" by simp
    also from V
    have "τExec_mover_a P t (syncV (e1) e2) h ([Addr a], loc, length (compE2 e1), None) ([Addr a], loc[V := Addr a], Suc (Suc (length (compE2 e1))), None)"
      by -(rule τExecr2step,auto intro: exec_instr τmove2_τmoves2.intros simp add: exec_move_def)
    also (rtranclp_trans)
    have "exec_move_a P t (syncV (e1) e2) h ([Addr a], loc[V := Addr a], Suc (Suc (length (compE2 e1))), None)
                        (Locka, SyncLock a)
                        h ([], loc[V := Addr a], Suc (Suc (Suc (length (compE2 e1)))), None)"
      unfolding exec_move_def by -(rule exec_instr, auto simp add: is_Ref_def)
    moreover have "¬ τmove2 (compP2 P) h [Addr a] (syncV (e1) e2) (Suc (Suc (length (compE2 e1)))) None"
      by(simp add: τmove2_iff)
    moreover
    from bisim1Sync4[OF bisim1_refl, of P h V e1 e2 a "loc[V := Addr a]"]
    have "P,syncV (e1) e2,h  (insyncV (a) e2, loc[V := Addr a])  ([], loc[V := Addr a], Suc (Suc (Suc (length (compE2 e1)))), None)" by simp
    moreover have "¬ τmove1 P h (syncV (addr a) e2)" by(auto simp add: τmove1.simps τmoves1.simps)
    ultimately show ?thesis by(auto simp add: eval_nat_numeral ta_upd_simps) blast
  next
    case (Synchronized1Throw1 a)
    note [simp] = e1' = Throw a ta = ε e' = Throw a h' = h xs' = xs
    have τ: "τmove1 P h (syncV (Throw a) e2)" by(rule τmove1SyncThrow)
    from bisim1 have "xcp = a  xcp = None" by(auto dest: bisim1_ThrowD)
    thus ?thesis
    proof
      assume [simp]: "xcp = a"
      with bisim1
      have "P, syncV (e1) e2, h  (Throw a, xs)  (stk, loc, pc, a)"
        by(auto intro: bisim1SyncThrow)
      thus ?thesis using τ by(fastforce)
    next
      assume [simp]: "xcp = None"
      with bisim1 obtain pc'
        where "τExec_mover_a P t e1 h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        and bisim': "P, e1, h  (Throw a, xs)  ([Addr a], loc, pc', a)" and [simp]: "xs = loc"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t (syncV (e1) e2) h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        by-(rule Sync_τExecrI)
      moreover from bisim'
      have "P, syncV (e1) e2, h  (Throw a, xs)  ([Addr a], loc, pc', a)"
        by -(rule bisim1_bisims1.bisim1SyncThrow, auto)
      ultimately show ?thesis using τ by fastforce
    qed
  qed
next
  case (bisim1Sync2 e1 n e2 V v xs)
  note bisim1 = xs. P,e1,h  (e1, xs)  ([], xs, 0, None)
  note bisim2 = xs. P,e2,h  (e2, xs)  ([], xs, 0, None)
  from ‹True,P,t ⊢1 syncV (Val v) e2,(h, xs) -ta e',(h', xs') show ?case
  proof cases
    case (Lock1Synchronized a)
    note [simp] = v = Addr a ta = Locka, SyncLock a e' = insyncV (a) e2
      h' = h xs' = xs[V := Addr a] 
      and V = V < length xs
    from V
    have "τExec_mover_a P t (syncV (e1) e2) h ([Addr a, Addr a], xs, Suc (length (compE2 e1)), None) ([Addr a], xs[V := Addr a], Suc (Suc (length (compE2 e1))), None)"
      by -(rule τExecr1step,auto intro: exec_instr simp add: τmove2_iff exec_move_def)
    moreover
    have "exec_move_a P t (syncV (e1) e2) h ([Addr a], xs[V := Addr a], Suc (Suc (length (compE2 e1))), None)
                        (Locka, SyncLock a)
                        h ([], xs[V := Addr a], Suc (Suc (Suc (length (compE2 e1)))), None)"
      unfolding exec_move_def by -(rule exec_instr, auto simp add: is_Ref_def)
    moreover have "¬ τmove2 (compP2 P) h [Addr a] (syncV (e1) e2) (Suc (Suc (length (compE2 e1)))) None"
      by(simp add: τmove2_iff)
    moreover
    from bisim1Sync4[OF bisim1_refl, of P h V e1 e2 a "xs[V := Addr a]"]
    have "P,syncV (e1) e2,h  (insyncV (a) e2, xs[V := Addr a])  ([], xs[V := Addr a], Suc (Suc (Suc (length (compE2 e1)))), None)" by simp
    moreover have "¬ τmove1 P h (syncV (addr a) e2)" by(auto simp add: τmove1.simps τmoves1.simps)
    ultimately show ?thesis by(auto simp add: eval_nat_numeral ta_upd_simps) blast
  next
    case Synchronized1Null
    note [simp] = v = Null› e' = THROW NullPointer› ta = ε h' = h xs' = xs[V := Null]
      and V = V < length xs
    from V
    have "τExec_mover_a P t (syncV (e1) e2) h ([Null, Null], xs, Suc (length (compE2 e1)), None) ([Null], xs[V := Null], Suc (Suc (length (compE2 e1))), None)"
      by -(rule τExecr1step,auto intro: exec_instr simp add: exec_move_def τmove2_iff)
    also have "exec_move_a P t (syncV (e1) e2) h ([Null], xs[V := Null], Suc (Suc (length (compE2 e1))), None) ε
                        h ([Null], xs[V := Null], Suc (Suc (length (compE2 e1))), addr_of_sys_xcpt NullPointer)"
      unfolding exec_move_def by(rule exec_instr) auto
    moreover have "¬ τmove2 (compP2 P) h [Null] (syncV (e1) e2) (Suc (Suc (length (compE2 e1)))) None"
      by(simp add: τmove2_iff)
    moreover 
    have "P,syncV (e1) e2,h  (THROW NullPointer, xs[V := Null])  ([Null], (xs[V := Null]), Suc (Suc (length (compE2 e1))), addr_of_sys_xcpt NullPointer)"
      by(rule bisim1Sync11)
    moreover have "¬ τmove1 P h (syncV (null) e2)" by(auto simp add: τmove1.simps τmoves1.simps)
    ultimately show ?thesis by(auto simp add: eval_nat_numeral) blast
  qed auto
next
  case (bisim1Sync3 e1 n e2 V v xs)
  note bisim1 = xs. P,e1,h  (e1, xs)  ([], xs, 0, None)
  note bisim2 = xs. P,e2,h  (e2, xs)  ([], xs, 0, None)
  from ‹True,P,t ⊢1 syncV (Val v) e2,(h, xs) -ta e',(h', xs') show ?case
  proof cases
    case (Lock1Synchronized a)
    note [simp] = v = Addr a ta = Locka, SyncLock a e' = insyncV (a) e2 h' = h xs' = xs[V := Addr a] 
      and V = V < length xs
    have "exec_move_a P t (syncV (e1) e2) h ([Addr a], xs[V := Addr a], Suc (Suc (length (compE2 e1))), None)
                        (Locka, SyncLock a)
                        h ([], xs[V := Addr a], Suc (Suc (Suc (length (compE2 e1)))), None)"
      unfolding exec_move_def by -(rule exec_instr, auto simp add: is_Ref_def)
    moreover have "¬ τmove2 (compP2 P) h [Addr a] (syncV (e1) e2) (Suc (Suc (length (compE2 e1)))) None"
      by(simp add: τmove2_iff)
    moreover
    from bisim1Sync4[OF bisim1_refl, of P h V e1 e2 a "xs[V := Addr a]"]
    have "P,syncV (e1) e2,h  (insyncV (a) e2, xs[V := Addr a])  ([], xs[V := Addr a], Suc (Suc (Suc (length (compE2 e1)))), None)" by simp
    moreover have "¬ τmove1 P h (syncV (addr a) e2)" by(auto simp add: τmove1.simps τmoves1.simps)
    ultimately show ?thesis by(auto simp add: eval_nat_numeral ta_upd_simps) blast
  next
    case Synchronized1Null
    note [simp] = v = Null› e' = THROW NullPointer› ta = ε h' = h xs' = xs[V := Null] 
      and V = V < length xs
    have "exec_move_a P t (syncV (e1) e2) h ([Null], xs[V := Null], Suc (Suc (length (compE2 e1))), None) ε
                        h ([Null], xs[V := Null], Suc (Suc (length (compE2 e1))), addr_of_sys_xcpt NullPointer)"
      unfolding exec_move_def by(rule exec_instr) auto
    moreover have "¬ τmove2 (compP2 P) h [Null] (syncV (e1) e2) (Suc (Suc (length (compE2 e1)))) None"
      by(simp add: τmove2_iff)
    moreover
    have "P,syncV (e1) e2,h  (THROW NullPointer, xs[V := Null])  ([Null], (xs[V := Null]), Suc (Suc (length (compE2 e1))), addr_of_sys_xcpt NullPointer)"
      by(rule bisim1Sync11)
    moreover have "¬ τmove1 P h (syncV (null) e2)" by(auto simp add: τmove1.simps τmoves1.simps)
    ultimately show ?thesis by(auto simp add: eval_nat_numeral) blast
  qed auto
next
  case (bisim1Sync4 e2 n e2' xs stk loc pc xcp e1 V a)
  note IH = bisim1Sync4.IH(2)
  note bisim2 = P,e2,h  (e2', xs)  (stk, loc, pc, xcp)
  note bisim1 = xs. P,e1,h  (e1, xs)  ([], xs, 0, None)
  note bsok = ‹bsok (syncV (e1) e2) n
  note red = ‹True,P,t ⊢1 insyncV (a) e2',(h, xs) -ta e',(h', xs')
  from red show ?case
  proof cases
    case (Synchronized1Red2 E')
    note [simp] = e' = insyncV (a) E'
      and red = ‹True,P,t ⊢1 e2', (h, xs) -ta E', (h', xs')
    from red have τ: "τmove1 P h (insyncV (a) e2') = τmove1 P h e2'" by(auto simp add: τmove1.simps τmoves1.simps)
    from IH[OF red] bsok obtain pc'' stk'' loc'' xcp''
      where bisim': "P,e2,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and exec': "?exec ta e2 e2' E' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    have "no_call2 e2 pc  no_call2 (syncV(e1) e2) (Suc (Suc (Suc (length (compE2 e1) + pc))))"
      by(auto simp add: no_call2_def)
    hence "?exec ta (syncV (e1) e2) (insyncV (a) e2') (insyncV (a) E') h stk loc (Suc (Suc (Suc (length (compE2 e1) + pc)))) xcp h' (Suc (Suc (Suc (length (compE2 e1) + pc'')))) stk'' loc'' xcp''"
      using exec' τ
      by(cases "τmove1 P h (insyncV (a) e2')")(auto,(blast intro: exec_move_SyncI2 Insync_τExecrI Insync_τExectI)+)
    moreover from bisim'
    have "P,syncV (e1) e2,h'  (insyncV (a) E', xs')  (stk'', loc'', (Suc (Suc (Suc (length (compE2 e1) + pc'')))), xcp'')"
      by(rule bisim1_bisims1.bisim1Sync4)
    ultimately show ?thesis using τ by auto blast+
  next
    case (Unlock1Synchronized a' v)
    note [simp] = e2' = Val v e' = Val v ta = Unlocka', SyncUnlock a' h' = h xs' = xs
      and V = V < length xs and xsV = xs ! V = Addr a'
    from bisim2 have [simp]: "xcp = None" "xs = loc"
      and exec: "τExec_mover_a P t e2 h (stk, loc, pc, xcp) ([v], loc, length (compE2 e2), None)"
      by(auto dest: bisim1Val2D1)
    let ?pc1 = "(Suc (Suc (Suc (length (compE2 e1) + length (compE2 e2)))))"
    note Insync_τExecrI[OF exec, of V e1]
    also from V xsV have "τExec_mover_a P t (syncV (e1) e2) h ([v], loc, ?pc1, None) ([Addr a', v], loc, Suc ?pc1, None)"
      by -(rule τExecr1step,auto simp add: exec_move_def intro: exec_instr τmove2_τmoves2.intros)
    also (rtranclp_trans)
    have "exec_move_a P t (syncV (e1) e2) h ([Addr a', v], loc, Suc ?pc1, None) (Unlocka', SyncUnlock a') h ([v], loc, Suc (Suc ?pc1), None)"
      unfolding exec_move_def by(rule exec_instr)(auto simp add: is_Ref_def)
    moreover have "¬ τmove2 (compP2 P) h [Addr a', v] (syncV (e1) e2) (Suc ?pc1) None" by(simp add: τmove2_iff)
    moreover
    from bisim1Sync6[of P h V e1 e2 v xs]
    have "P,syncV (e1) e2,h  (Val v, xs)  ([v], xs, Suc (Suc ?pc1), None)"
      by(auto simp add: eval_nat_numeral)
    moreover have "¬ τmove1 P h (insyncV (a) e2')" by(auto simp add: τmove1.simps τmoves1.simps)
    ultimately show ?thesis by(auto simp add: ta_upd_simps) blast
  next
    case (Unlock1SynchronizedNull v)
    note [simp] = e2' = Val v e' = THROW NullPointer› ta = ε h' = h xs' = xs
      and V = V < length xs and xsV = xs ! V = Null›
    from bisim2 have [simp]: "xcp = None" "xs = loc"
      and exec: "τExec_mover_a P t e2 h (stk, loc, pc, xcp) ([v], loc, length (compE2 e2), None)"
      by(auto dest: bisim1Val2D1)
    let ?pc1 = "(Suc (Suc (Suc (length (compE2 e1) + length (compE2 e2)))))"
    note Insync_τExecrI[OF exec, of V e1]
    also from V xsV have "τExec_mover_a P t (syncV (e1) e2) h ([v], loc, ?pc1, None) ([Null, v], loc, Suc ?pc1, None)"
      by -(rule τExecr1step,auto intro: exec_instr τmove2_τmoves2.intros simp add: exec_move_def)
    also (rtranclp_trans)
    have "exec_move_a P t (syncV (e1) e2) h ([Null, v], loc, Suc ?pc1, None) ε h ([Null, v], loc, Suc ?pc1, addr_of_sys_xcpt NullPointer)"
      unfolding exec_move_def by(rule exec_instr)(auto simp add: is_Ref_def)
    moreover have "¬ τmove2 (compP2 P) h [Null, v] (syncV (e1) e2) (Suc ?pc1) None" by(simp add: τmove2_iff)
    moreover 
    from bisim1Sync12[of P h V e1 e2 "addr_of_sys_xcpt NullPointer" xs]
    have "P,syncV (e1) e2,h  (THROW NullPointer,xs)  ([Null, v],xs,Suc ?pc1,addr_of_sys_xcpt NullPointer)"
      by(auto simp add: eval_nat_numeral)
    moreover have "¬ τmove1 P h (insyncV (a) e2')" by(auto simp add: τmove1.simps τmoves1.simps)
    ultimately show ?thesis by auto blast
  next
    case (Unlock1SynchronizedFail a' v)
    note [simp] = e2' = Val v e' = THROW IllegalMonitorState› ta = UnlockFaila' xs' = xs h' = h
      and V = V < length xs and xsV = xs ! V = Addr a'
    from bisim2 have [simp]: "xcp = None" "xs = loc"
      and exec: "τExec_mover_a P t e2 h (stk, loc, pc, xcp) ([v], loc, length (compE2 e2), None)"
      by(auto dest: bisim1Val2D1)
    let ?pc1 = "(Suc (Suc (Suc (length (compE2 e1) + length (compE2 e2)))))"
    note Insync_τExecrI[OF exec, of V e1]
    also from V xsV have "τExec_mover_a P t (syncV (e1) e2) h ([v], loc, ?pc1, None) ([Addr a', v], loc, Suc ?pc1, None)"
      by -(rule τExecr1step,auto intro: exec_instr τmove2_τmoves2.intros simp add: exec_move_def)
    also (rtranclp_trans)
    have "exec_move_a P t (syncV (e1) e2) h ([Addr a', v], loc, Suc ?pc1, None) UnlockFaila' h ([Addr a', v], loc, Suc ?pc1, addr_of_sys_xcpt IllegalMonitorState)"
      unfolding exec_move_def by(rule exec_instr)(auto simp add: is_Ref_def)
    moreover have "¬ τmove2 (compP2 P) h [Addr a', v] (syncV (e1) e2) (Suc ?pc1) None" by(simp add: τmove2_iff)
    moreover
    from bisim1Sync12[of P h V e1 e2 "addr_of_sys_xcpt IllegalMonitorState" xs "Addr a'" v]
    have "P,syncV (e1) e2,h  (THROW IllegalMonitorState,xs)  ([Addr a', v],xs,Suc ?pc1,addr_of_sys_xcpt IllegalMonitorState)"
      by(auto simp add: eval_nat_numeral)
    moreover have "¬ τmove1 P h (insyncV (a) Val v)" by(auto simp add: τmove1.simps τmoves1.simps)
    ultimately show ?thesis by(auto simp add: ta_upd_simps) blast
  next
    case (Synchronized1Throw2 a' ad)
    note [simp] = e2' = Throw ad ta = Unlocka', SyncUnlock a' e' = Throw ad
      h' = h xs' = xs and xsV = xs ! V = Addr a' and V = V < length xs
    let ?pc = "6 + length (compE2 e1) + length (compE2 e2)"
    let ?stk = "Addr ad # drop (size stk - 0) stk"
    from bisim2 have [simp]: "xs = loc" by(auto dest: bisim1_ThrowD)
    from bisim2
    have "τExec_movet_a P t (syncV (e1) e2) h (stk, loc, Suc (Suc (Suc (length (compE2 e1) + pc))), xcp) ([Addr ad], loc, ?pc, None)"    
      by(auto intro: bisim1_insync_Throw_exec)
    also from xsV V 
    have "τExec_movet_a P t (syncV (e1) e2) h ([Addr ad], loc, ?pc, None) ([Addr a', Addr ad], loc, Suc ?pc, None)"
      by -(rule τExect1step,auto intro: exec_instr τmove2Sync7 simp add: exec_move_def)
    also (tranclp_trans)
    have "exec_move_a P t (syncV (e1) e2) h ([Addr a', Addr ad], loc, Suc ?pc, None) (Unlocka', SyncUnlock a') h ([Addr ad], loc, Suc (Suc ?pc), None)"
      unfolding exec_move_def by(rule exec_instr)(auto simp add: is_Ref_def)
    moreover have "¬ τmove2 (compP2 P) h [Addr a', Addr ad] (syncV (e1) e2) (Suc ?pc) None" by(simp add: τmove2_iff)
    moreover
    hence "P, syncV (e1) e2, h  (Throw ad, loc)  ([Addr ad], loc, 8 + length (compE2 e1) + length (compE2 e2), None)"
      by(auto intro: bisim1Sync9)
    moreover have "¬ τmove1 P h (insyncV (a) Throw ad)" by(auto simp add: τmove1.simps τmoves1.simps)
    ultimately show ?thesis by(auto simp add: add.assoc ta_upd_simps)(blast intro: tranclp_into_rtranclp)
  next
    case (Synchronized1Throw2Fail a' ad)
    note [simp] = e2' = Throw ad ta = UnlockFaila' e' = THROW IllegalMonitorState› h' = h xs' = xs
      and xsV = xs ! V = Addr a' and V = V < length xs
    let ?pc = "6 + length (compE2 e1) + length (compE2 e2)"
    let ?stk = "Addr ad # drop (size stk - 0) stk"
    from bisim2 have [simp]: "xs = loc" by(auto dest: bisim1_ThrowD)
    from bisim2
    have "τExec_movet_a P t (syncV (e1) e2) h (stk, loc, Suc (Suc (Suc (length (compE2 e1) + pc))), xcp) ([Addr ad], loc, ?pc, None)"
      by(auto intro: bisim1_insync_Throw_exec)
    also from xsV V
    have "τExec_movet_a P t (syncV (e1) e2) h ([Addr ad], loc, ?pc, None) ([Addr a', Addr ad], loc, Suc ?pc, None)"
      by -(rule τExect1step,auto intro: exec_instr τmove2Sync7 simp add: exec_move_def)
    also (tranclp_trans)
    have "exec_move_a P t (syncV (e1) e2) h ([Addr a', Addr ad], loc, Suc ?pc, None) UnlockFaila' h ([Addr a', Addr ad], loc, Suc ?pc, addr_of_sys_xcpt IllegalMonitorState)"
      unfolding exec_move_def by(rule exec_instr)(auto simp add: is_Ref_def)
    moreover have "¬ τmove2 (compP2 P) h [Addr a', Addr ad] (syncV (e1) e2) (Suc ?pc) None" by(simp add: τmove2_iff)
    moreover
    hence "P, syncV (e1) e2, h  (THROW IllegalMonitorState, loc)  ([Addr a', Addr ad], loc, 7 + length (compE2 e1) + length (compE2 e2), addr_of_sys_xcpt IllegalMonitorState)"
      by(auto intro: bisim1Sync14)
    moreover have "¬ τmove1 P h (insyncV (a) e2')"  by(auto simp add: τmove1.simps τmoves1.simps)
    ultimately show ?thesis by(auto simp add: add.assoc ta_upd_simps)(blast intro: tranclp_into_rtranclp)
  next
    case (Synchronized1Throw2Null ad)
    note [simp] = e2' = Throw ad ta = ε e' = THROW NullPointer› h' = h xs' = xs
      and xsV = xs ! V = Null› and V = V < length xs
    let ?pc = "6 + length (compE2 e1) + length (compE2 e2)"
    let ?stk = "Addr ad # drop (size stk - 0) stk"
    from bisim2 have [simp]: "xs = loc" by(auto dest: bisim1_ThrowD)
    from bisim2
    have "τExec_movet_a P t (syncV (e1) e2) h (stk, loc, Suc (Suc (Suc (length (compE2 e1) + pc))), xcp) ([Addr ad], loc, ?pc, None)"
      by(auto intro: bisim1_insync_Throw_exec)
    also from xsV V 
    have "τExec_movet_a P t (syncV (e1) e2) h ([Addr ad], loc, ?pc, None) ([Null, Addr ad], loc, Suc ?pc, None)"
      by -(rule τExect1step,auto intro: exec_instr simp add: exec_move_def τmove2_iff)
    also (tranclp_trans)
    have "exec_move_a P t (syncV (e1) e2) h ([Null, Addr ad], loc, Suc ?pc, None) ε h ([Null, Addr ad], loc, Suc ?pc, addr_of_sys_xcpt NullPointer)"
      unfolding exec_move_def by(rule exec_instr)(auto simp add: is_Ref_def)
    moreover have "¬ τmove2 (compP2 P) h [Null, Addr ad] (syncV (e1) e2) (Suc ?pc) None" by(simp add: τmove2_iff)
    moreover
    hence "P, syncV (e1) e2, h  (THROW NullPointer, loc)  ([Null, Addr ad], loc, 7 + length (compE2 e1) + length (compE2 e2), addr_of_sys_xcpt NullPointer)"
      by(auto intro: bisim1Sync14)
    moreover have "¬ τmove1 P h (insyncV (a) e2')"  by(auto simp add: τmove1.simps τmoves1.simps)
    ultimately show ?thesis by(auto simp add: add.assoc)(blast intro: tranclp_into_rtranclp)
  qed
next
  case (bisim1Sync5 e1 n e2 V a v xs)
  note bisim2 = xs. P,e2,h  (e2, xs)  ([], xs, 0, None)
  note bisim1 = xs. P,e1,h  (e1, xs)  ([], xs, 0, None)
  from ‹True,P,t ⊢1 insyncV (a) Val v,(h, xs) -ta e',(h', xs') show ?case
  proof cases
    case (Unlock1Synchronized a')
    note [simp] = e' = Val v ta = Unlocka', SyncUnlock a' h' = h xs' = xs
      and V = V < length xs and xsV = xs ! V = Addr a'
    let ?pc1 = "4 + length (compE2 e1) + length (compE2 e2)"
    have "exec_move_a P t (syncV (e1) e2) h ([Addr a', v], xs, ?pc1, None) Unlocka', SyncUnlock a' h ([v], xs, Suc ?pc1, None)"
      unfolding exec_move_def by(rule exec_instr)(auto simp add: is_Ref_def)
    moreover have "¬ τmove2 (compP2 P) h [Addr a', v] (syncV (e1) e2) ?pc1 None" by(simp add: τmove2_iff)
    moreover 
    from bisim1Sync6[of P h V e1 e2 v xs]
    have "P,syncV (e1) e2,h  (Val v, xs)  ([v], xs, Suc ?pc1, None)"
      by(auto simp add: eval_nat_numeral)
    moreover have "¬ τmove1 P h (insyncV (a) Val v)" by(auto simp add: τmove1.simps τmoves1.simps)
    ultimately show ?thesis using xsV by(auto simp add: eval_nat_numeral ta_upd_simps) blast
  next
    case Unlock1SynchronizedNull
    note [simp] = e' = THROW NullPointer› ta = ε h' = h xs' = xs
      and V = V < length xs and xsV = xs ! V = Null›
    let ?pc1 = "4 + length (compE2 e1) + length (compE2 e2)"
    have "exec_move_a P t (syncV (e1) e2) h ([Null, v], xs, ?pc1, None) ε h ([Null, v], xs, ?pc1, addr_of_sys_xcpt NullPointer)"
      unfolding exec_move_def by(rule exec_instr)(auto simp add: is_Ref_def)
    moreover have "¬ τmove2 (compP2 P) h [Null, v] (syncV (e1) e2) ?pc1 None" by(simp add: τmove2_iff)
    moreover 
    from bisim1Sync12[of P h V e1 e2 "addr_of_sys_xcpt NullPointer" xs Null v]
    have "P,syncV (e1) e2,h  (THROW NullPointer,xs)  ([Null, v],xs,?pc1,addr_of_sys_xcpt NullPointer)"
      by(auto simp add: eval_nat_numeral)
    moreover have "¬ τmove1 P h (insyncV (a) Val v)" by(auto simp add: τmove1.simps τmoves1.simps)
    ultimately show ?thesis using xsV by(auto simp add: eval_nat_numeral) blast
  next
    case (Unlock1SynchronizedFail a')
    note [simp] = e' = THROW IllegalMonitorState› ta = UnlockFaila' xs' = xs h' = h
      and V = V < length xs and xsV = xs ! V = Addr a'
    let ?pc1 = "4 + length (compE2 e1) + length (compE2 e2)"
    have "exec_move_a P t (syncV (e1) e2) h ([Addr a', v], xs, ?pc1, None) UnlockFaila' h ([Addr a', v], xs, ?pc1, addr_of_sys_xcpt IllegalMonitorState)"
      unfolding exec_move_def by(rule exec_instr)(auto simp add: is_Ref_def)
    moreover have "¬ τmove2 (compP2 P) h [Addr a', v] (syncV (e1) e2) ?pc1 None" by(simp add: τmove2_iff)
    moreover 
    from bisim1Sync12[of P h V e1 e2 "addr_of_sys_xcpt IllegalMonitorState" xs "Addr a'" v]
    have "P,syncV (e1) e2,h  (THROW IllegalMonitorState,xs)  ([Addr a', v],xs,?pc1,addr_of_sys_xcpt IllegalMonitorState)"
      by(auto simp add: eval_nat_numeral)
    moreover have "¬ τmove1 P h (insyncV (a) Val v)" by(auto simp add: τmove1.simps τmoves1.simps)
    ultimately show ?thesis using xsV by(auto simp add: eval_nat_numeral ta_upd_simps) blast
  qed auto
next
  case bisim1Sync6 thus ?case by auto
next
  case (bisim1Sync7 e1 n e2 V a ad xs)
  note bisim2 = xs. P,e2,h  (e2, xs)  ([], xs, 0, None)
  note bisim1 = xs. P,e1,h  (e1, xs)  ([], xs, 0, None)
  from ‹True,P,t ⊢1 insyncV (a) Throw ad,(h, xs) -ta e',(h', xs') show ?case
  proof cases
    case (Synchronized1Throw2 a')
    note [simp] = ta = Unlocka', SyncUnlock a' e' = Throw ad h' = h xs' = xs
      and xsV = xs ! V = Addr a' and V = V < length xs
    let ?pc = "6 + length (compE2 e1) + length (compE2 e2)"
    from xsV V
    have "τExec_mover_a P t (syncV (e1) e2) h ([Addr ad], xs, ?pc, None) ([Addr a', Addr ad], xs, Suc ?pc, None)"
      by -(rule τExecr1step,auto intro: exec_instr simp add: exec_move_def τmove2_iff)
    moreover have "exec_move_a P t (syncV (e1) e2) h ([Addr a', Addr ad], xs, Suc ?pc, None) Unlocka', SyncUnlock a' h ([Addr ad], xs, Suc (Suc ?pc), None)"
      unfolding exec_move_def by(rule exec_instr)(auto simp add: is_Ref_def)
    moreover have "¬ τmove2 (compP2 P) h [Addr a', Addr ad] (syncV (e1) e2) (Suc ?pc) None" by(simp add: τmove2_iff)
    moreover
    have "P, syncV (e1) e2, h  (Throw ad, xs)  ([Addr ad], xs, 8 + length (compE2 e1) + length (compE2 e2), None)"
      by(auto intro: bisim1Sync9)
    moreover have "¬ τmove1 P h (insyncV (a) Throw ad)" by(auto simp add: τmove1.simps τmoves1.simps)
    ultimately show ?thesis by(auto simp add: add.assoc eval_nat_numeral ta_upd_simps) blast
  next
    case (Synchronized1Throw2Fail a')
    note [simp] = ta = UnlockFaila' e' = THROW IllegalMonitorState› h' = h xs' = xs
      and xsV = xs ! V = Addr a' and V = V < length xs
    let ?pc = "6 + length (compE2 e1) + length (compE2 e2)"
    from xsV V
    have "τExec_mover_a P t (syncV (e1) e2) h ([Addr ad], xs, ?pc, None) ([Addr a', Addr ad], xs, Suc ?pc, None)"
      by -(rule τExecr1step,auto intro: exec_instr simp add: exec_move_def τmove2_iff)
    moreover have "exec_move_a P t (syncV (e1) e2) h ([Addr a', Addr ad], xs, Suc ?pc, None) UnlockFaila' h ([Addr a', Addr ad], xs, Suc ?pc, addr_of_sys_xcpt IllegalMonitorState)"
      unfolding exec_move_def by(rule exec_instr)(auto simp add: is_Ref_def)
    moreover have "¬ τmove2 (compP2 P) h [Addr a', Addr ad] (syncV (e1) e2) (Suc ?pc) None" by(simp add: τmove2_iff)
    moreover
    have "P, syncV (e1) e2, h  (THROW IllegalMonitorState, xs)  ([Addr a', Addr ad], xs, 7 + length (compE2 e1) + length (compE2 e2), addr_of_sys_xcpt IllegalMonitorState)"
      by(auto intro: bisim1Sync14)
    moreover have "¬ τmove1 P h (insyncV (a) Throw ad)" by(auto simp add: τmove1.simps τmoves1.simps)
    ultimately show ?thesis by(auto simp add: add.assoc ta_upd_simps) blast
  next
    case Synchronized1Throw2Null
    note [simp] = ta = ε e' = THROW NullPointer› h' = h xs' = xs
      and xsV = xs ! V = Null› and V = V < length xs
    let ?pc = "6 + length (compE2 e1) + length (compE2 e2)"
    from xsV V 
    have "τExec_mover_a P t (syncV (e1) e2) h ([Addr ad], xs, ?pc, None) ([Null, Addr ad], xs, Suc ?pc, None)"
      by -(rule τExecr1step,auto intro: exec_instr simp add: exec_move_def τmove2_iff)
    moreover have "exec_move_a P t (syncV (e1) e2) h ([Null, Addr ad], xs, Suc ?pc, None) ε h ([Null, Addr ad], xs, Suc ?pc, addr_of_sys_xcpt NullPointer)"
      unfolding exec_move_def by(rule exec_instr)(auto simp add: is_Ref_def)
    moreover have "¬ τmove2 (compP2 P) h [Null, Addr ad] (syncV (e1) e2) (Suc ?pc) None" by(simp add: τmove2_iff)
    moreover 
    have "P, syncV (e1) e2, h  (THROW NullPointer, xs)  ([Null, Addr ad], xs, 7 + length (compE2 e1) + length (compE2 e2), addr_of_sys_xcpt NullPointer)"
      by(auto intro: bisim1Sync14)
    moreover have "¬ τmove1 P h (insyncV (a) Throw ad)" by(auto simp add: τmove1.simps τmoves1.simps)
    ultimately show ?thesis by(auto simp add: add.assoc) blast
  qed auto 
next
  case (bisim1Sync8 e1 n e2 V a ad xs)
  note bisim2 = xs. P,e2,h  (e2, xs)  ([], xs, 0, None)
  note bisim1 = xs. P,e1,h  (e1, xs)  ([], xs, 0, None)
  from ‹True,P,t ⊢1 insyncV (a) Throw ad,(h, xs) -ta e',(h', xs') show ?case
  proof cases
    case (Synchronized1Throw2 a')
    note [simp] = ta = Unlocka', SyncUnlock a' e' = Throw ad h' = h xs' = xs
      and xsV = xs ! V = Addr a' and V = V < length xs
    let ?pc = "7 + length (compE2 e1) + length (compE2 e2)"
    have "exec_move_a P t (syncV (e1) e2) h ([Addr a', Addr ad], xs, ?pc, None) Unlocka', SyncUnlock a' h ([Addr ad], xs, Suc ?pc, None)"
      unfolding exec_move_def by(rule exec_instr)(auto simp add: is_Ref_def)
    moreover have "¬ τmove2 (compP2 P) h [Addr a', Addr ad] (syncV (e1) e2) ?pc None" by(simp add: τmove2_iff)
    moreover
    have "P, syncV (e1) e2, h  (Throw ad, xs)  ([Addr ad], xs, 8 + length (compE2 e1) + length (compE2 e2), None)"
      by(auto intro: bisim1Sync9)
    moreover have "¬ τmove1 P h (insyncV (a) Throw ad)" by(auto simp add: τmove1.simps τmoves1.simps)
    ultimately show ?thesis using xsV by(auto simp add: add.assoc eval_nat_numeral ta_upd_simps) blast
  next
    case (Synchronized1Throw2Fail a')
    note [simp] = ta = UnlockFaila' e' = THROW IllegalMonitorState› h' = h xs' = xs 
      and xsV = xs ! V = Addr a' and V = V < length xs
    let ?pc = "7 + length (compE2 e1) + length (compE2 e2)"
    have "exec_move_a P t (syncV (e1) e2) h ([Addr a', Addr ad], xs, ?pc, None) UnlockFaila' h ([Addr a', Addr ad], xs, ?pc, addr_of_sys_xcpt IllegalMonitorState)"
      unfolding exec_move_def by(rule exec_instr)(auto simp add: is_Ref_def)
    moreover have "¬ τmove2 (compP2 P) h [Addr a', Addr ad] (syncV (e1) e2) ?pc None" by(simp add: τmove2_iff)
    moreover
    have "P, syncV (e1) e2, h  (THROW IllegalMonitorState, xs)  ([Addr a', Addr ad], xs, ?pc, addr_of_sys_xcpt IllegalMonitorState)"
      by(auto intro: bisim1Sync14)
    moreover have "¬ τmove1 P h (insyncV (a) Throw ad)" by(auto simp add: τmove1.simps τmoves1.simps)
    ultimately show ?thesis using xsV by(auto simp add: add.assoc ta_upd_simps) blast
  next
    case Synchronized1Throw2Null
    note [simp] = ta = ε e' = THROW NullPointer› h' = h xs' = xs
      and xsV = xs ! V = Null› and V = V < length xs
    let ?pc = "7 + length (compE2 e1) + length (compE2 e2)"
    have "exec_move_a P t (syncV (e1) e2) h ([Null, Addr ad], xs, ?pc, None) ε h ([Null, Addr ad], xs, ?pc, addr_of_sys_xcpt NullPointer)"
      unfolding exec_move_def by(rule exec_instr)(auto simp add: is_Ref_def)
    moreover have "¬ τmove2 (compP2 P) h [Null, Addr ad] (syncV (e1) e2) ?pc None" by(simp add: τmove2_iff)
    moreover
    have "P, syncV (e1) e2, h  (THROW NullPointer, xs)  ([Null, Addr ad], xs, ?pc, addr_of_sys_xcpt NullPointer)"
      by(auto intro: bisim1Sync14)
    moreover have "¬ τmove1 P h (insyncV (a) Throw ad)" by(auto simp add: τmove1.simps τmoves1.simps)
    ultimately show ?thesis using xsV by(auto simp add: add.assoc) blast
  qed auto
next
  case bisim1Sync9 thus ?case by auto
next
  case bisim1Sync10 thus ?case by auto
next
  case bisim1Sync11 thus ?case by auto
next
  case bisim1Sync12 thus ?case by auto
next
  case bisim1Sync14 thus ?case by auto
next
  case bisim1SyncThrow thus ?case by auto
next
  case bisim1InSync thus ?case by simp
next
  case (bisim1Seq1 e1 n e1' xs stk loc pc xcp e2)
  note IH = bisim1Seq1.IH(2)
  note bisim1 = P,e1,h  (e1', xs)  (stk, loc, pc, xcp)
  note bisim2 = xs. P,e2,h  (e2, xs)  ([], xs, 0, None)
  note red = ‹True,P,t ⊢1 e1';; e2,(h, xs) -ta e',(h', xs')
  note bsok = ‹bsok (e1;; e2) n
  from red show ?case
  proof cases
    case (Seq1Red E')
    note [simp] = e' = E';;e2
      and red = ‹True,P,t ⊢1 e1', (h, xs) -ta E', (h', xs')
    from red have τ: "τmove1 P h (e1';; e2) = τmove1 P h e1'" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover have "call1 (e1';; e2) = call1 e1'" by auto
    moreover from IH[OF red] bsok
    obtain pc'' stk'' loc'' xcp'' where bisim: "P,e1,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and redo: "?exec ta e1 e1' E' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    from bisim have "P,e1;; e2,h'  (E';; e2, xs')  (stk'', loc'', pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1Seq1)
    moreover { 
      assume "no_call2 e1 pc"
      hence "no_call2 (e1;; e2) pc" by(auto simp add: no_call2_def) }
    ultimately show ?thesis using redo
      by(auto simp del: call1.simps calls1.simps split: if_split_asm split del: if_split)(blast intro: Seq_τExecrI1 Seq_τExectI1 exec_move_SeqI1)+
  next
    case (Red1Seq v)
    note [simp] = e1' = Val v ta = ε h' = h xs' = xs e' = e2
    from bisim1 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t e1 h (stk, loc, pc, xcp) ([v], loc, length (compE2 e1), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (e1;; e2) h (stk, loc, pc, xcp) ([v], loc, length (compE2 e1), None)"
      by-(rule Seq_τExecrI1)
    moreover have "exec_move_a P t (e1;; e2) h ([v], loc, length (compE2 e1), None) ε h ([], loc, Suc (length (compE2 e1)), None)"
      unfolding exec_move_def by(rule exec_instr, auto)
    moreover have "τmove2 (compP2 P) h [v] (e1;;e2) (length (compE2 e1)) None" by(simp add: τmove2_iff)
    ultimately have "τExec_mover_a P t (e1;; e2) h (stk, loc, pc, xcp) ([], loc, Suc (length (compE2 e1)), None)"
      by(auto intro: rtranclp.rtrancl_into_rtrancl τexec_moveI simp add: compP2_def)
    moreover from bisim1_refl
    have "P, e1;; e2, h  (e2, xs)  ([], loc, Suc (length (compE2 e1) + 0), None)"
      unfolding s by(rule bisim1Seq2)
    moreover have "τmove1 P h (Val v;; e2)" by(rule τmove1SeqRed)
    ultimately show ?thesis by(auto)
  next
    case (Seq1Throw a)
    note [simp] = e1' = Throw a ta = ε e' = Throw a h' = h xs' = xs
    have τ: "τmove1 P h (Throw a;; e2)" by(rule τmove1SeqThrow)
    from bisim1 have "xcp = a  xcp = None" by(auto dest: bisim1_ThrowD)
    thus ?thesis
    proof
      assume [simp]: "xcp = a"
      with bisim1 have "P, e1;; e2, h  (Throw a, xs)  (stk, loc, pc, xcp)"
        by(auto intro: bisim1SeqThrow1)
      thus ?thesis using τ by(fastforce)
    next
      assume [simp]: "xcp = None"
      with bisim1 obtain pc'
        where "τExec_mover_a P t e1 h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        and bisim': "P, e1, h  (Throw a, xs)  ([Addr a], loc, pc', a)" and [simp]: "xs = loc"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t (e1;;e2) h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        by-(rule Seq_τExecrI1)
      moreover from bisim'
      have "P, e1;;e2, h  (Throw a, xs)  ([Addr a], loc, pc', a)"
        by(rule bisim1SeqThrow1)
      ultimately show ?thesis using τ by auto
    qed
  qed
next
  case bisim1SeqThrow1 thus ?case by fastforce
next
  case (bisim1Seq2 e2 n e2' xs stk loc pc xcp e1)
  note IH = bisim1Seq2.IH(2)
  note bisim2 = P,e2,h  (e2', xs)  (stk, loc, pc, xcp)
  note bisim1 = xs. P,e1,h  (e1, xs)  ([], xs, 0, None)
  note red = ‹True,P,t ⊢1 e2',(h, xs) -ta e',(h', xs')
  note bsok = ‹bsok (e1;; e2) n
  from IH[OF red] bsok obtain pc'' stk'' loc'' xcp''
    where bisim': "P,e2,h'  (e', xs')  (stk'', loc'', pc'', xcp'')"
    and exec': "?exec ta e2 e2' e' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
  have "no_call2 e2 pc  no_call2 (e1;; e2) (Suc (length (compE2 e1) + pc))"
      by(auto simp add: no_call2_def)
  hence "?exec ta (e1;; e2) e2' e' h stk loc (Suc (length (compE2 e1) + pc)) xcp h' (Suc (length (compE2 e1) + pc'')) stk'' loc'' xcp''"
    using exec' by(cases "τmove1 P h e2'")(auto, (blast intro: Seq_τExecrI2 Seq_τExectI2 exec_move_SeqI2)+)
  moreover from bisim'
  have "P,e1;;e2,h'  (e', xs')  (stk'', loc'', Suc (length (compE2 e1) + pc''), xcp'')"
    by(rule bisim1_bisims1.bisim1Seq2)
  ultimately show ?case by(auto split: if_split_asm) blast+
next
  case (bisim1Cond1 E n e xs stk loc pc xcp e1 e2)
  note IH = bisim1Cond1.IH(2)
  note bisim = P,E,h  (e, xs)  (stk, loc, pc, xcp)
  note bisim1 = xs. P,e1,h  (e1, xs)  ([], xs, 0, None)
  note bisim2 = xs. P,e2,h  (e2, xs)  ([], xs, 0, None)
  note bsok = ‹bsok (if (E) e1 else e2) n
  from ‹True,P,t ⊢1 if (e) e1 else e2,(h, xs) -ta e',(h', xs') show ?case
  proof cases
    case (Cond1Red b')
    note [simp] = e' = if (b') e1 else e2
      and red = ‹True,P,t ⊢1 e,(h, xs) -ta b',(h', xs')
    from red have "τmove1 P h (if (e) e1 else e2) = τmove1 P h e" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover have "call1 (if (e) e1 else e2) = call1 e" by auto
    moreover from IH[OF red] bsok
    obtain pc'' stk'' loc'' xcp'' where bisim: "P,E,h'  (b', xs')  (stk'', loc'', pc'', xcp'')"
      and redo: "?exec ta E e b' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    from bisim
    have "P,if (E) e1 else e2,h'  (if (b') e1 else e2, xs')  (stk'', loc'', pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1Cond1)
    moreover { 
      assume "no_call2 E pc"
      hence "no_call2 (if (E) e1 else e2) pc" by(auto simp add: no_call2_def) }
    ultimately show ?thesis using redo
      by(auto simp del: call1.simps calls1.simps split: if_split_asm split del: if_split)(blast intro: Cond_τExecrI1 Cond_τExectI1 exec_move_CondI1)+
  next
    case Red1CondT
    note [simp] = e = true› e' = e1 ta = ε h' = h xs' = xs 
    from bisim have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t E h (stk, loc, pc, xcp) ([Bool True], loc, length (compE2 E), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (if (E) e1 else e2) h (stk, loc, pc, xcp) ([Bool True], loc, length (compE2 E), None)"
      by-(rule Cond_τExecrI1)
    moreover have "exec_move_a P t (if (E) e1 else e2) h ([Bool True], loc, length (compE2 E), None) ε h ([], loc, Suc (length (compE2 E)), None)"
      unfolding exec_move_def by(rule exec_instr, auto)
    moreover have "τmove2 (compP2 P) h [Bool True] (if (E) e1 else e2) (length (compE2 E)) None" by(simp add: τmove2_iff)
    ultimately have "τExec_movet_a P t (if (E) e1 else e2) h (stk, loc, pc, xcp) ([], loc, Suc (length (compE2 E)), None)"
      by(auto intro: rtranclp_into_tranclp1 τexec_moveI simp add: compP2_def)
    moreover have "τmove1 P h (if (true) e1 else e2)" by(rule τmove1CondRed)
    moreover
    from bisim1_refl
    have "P, if (E) e1 else e2, h  (e1, xs)  ([], loc, Suc (length (compE2 E) + 0), None)"
      unfolding s by(rule bisim1CondThen)
    ultimately show ?thesis by (fastforce)
  next
    case Red1CondF
    note [simp] = e = false› e' = e2 ta = ε h' = h xs' = xs
    from bisim have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t E h (stk, loc, pc, xcp) ([Bool False], loc, length (compE2 E), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (if (E) e1 else e2) h (stk, loc, pc, xcp) ([Bool False], loc, length (compE2 E), None)"
      by-(rule Cond_τExecrI1)
    moreover have "exec_move_a P t (if (E) e1 else e2) h ([Bool False], loc, length (compE2 E), None) ε h ([], loc, Suc (Suc (length (compE2 E) + length (compE2 e1))), None)"
      unfolding exec_move_def by(rule exec_instr)(auto)
    moreover have "τmove2 (compP2 P) h [Bool False] (if (E) e1 else e2) (length (compE2 E)) None" by(rule τmove2CondRed)
    ultimately have "τExec_movet_a P t (if (E) e1 else e2) h (stk, loc, pc, xcp) ([], loc, Suc (Suc (length (compE2 E) + length (compE2 e1))), None)"
      by(auto intro: rtranclp_into_tranclp1 τexec_moveI simp add: compP2_def)
    moreover have "τmove1 P h (if (false) e1 else e2)" by(rule τmove1CondRed)
    moreover 
    from bisim1_refl
    have "P, if (E) e1 else e2, h  (e2, loc)  ([], loc, (Suc (Suc (length (compE2 E) + length (compE2 e1) + 0))), None)"
      unfolding s by(rule bisim1CondElse)
    ultimately show ?thesis using s by auto(blast intro: tranclp_into_rtranclp)
  next
    case (Cond1Throw a)
    note [simp] = e = Throw a ta = ε e' = Throw a h' = h xs' = xs
    have τ: "τmove1 P h (if (Throw a) e1 else e2)" by(rule τmove1CondThrow)
    from bisim have "xcp = a  xcp = None" by(auto dest: bisim1_ThrowD)
    thus ?thesis
    proof
      assume [simp]: "xcp = a"
      with bisim
      have "P, if (E) e1 else e2, h  (Throw a, xs)  (stk, loc, pc, a)"
        by(auto intro: bisim1_bisims1.bisim1CondThrow)
      thus ?thesis using τ by(fastforce)
    next
      assume [simp]: "xcp = None"
      with bisim obtain pc'
        where "τExec_mover_a P t E h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        and bisim': "P, E, h  (Throw a, xs)  ([Addr a], loc, pc', a)" and [simp]: "xs = loc"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t (if (E) e1 else e2) h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        by-(rule Cond_τExecrI1)
      moreover from bisim'
      have "P, if (E) e1 else e2, h  (Throw a, xs)  ([Addr a], loc, pc', a)"
        by-(rule bisim1CondThrow, auto)
      ultimately show ?thesis using τ by auto
    qed
  qed
next
  case (bisim1CondThen e1 n e1' xs stk loc pc xcp e e2)
  note IH = bisim1CondThen.IH(2)
  note bisim1 = P,e1,h  (e1', xs)  (stk, loc, pc, xcp)
  note bisim = xs. P,e,h  (e, xs)  ([], xs, 0, None)
  note bisim2 = xs. P,e2,h  (e2, xs)  ([], xs, 0, None)
  note bsok = ‹bsok (if (e) e1 else e2) n
  from IH[OF ‹True,P,t ⊢1 e1',(h, xs) -ta e',(h', xs')] bsok obtain pc'' stk'' loc'' xcp''
    where bisim': "P,e1,h'  (e', xs')  (stk'', loc'', pc'', xcp'')"
    and exec': "?exec ta e1 e1' e' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
  have "no_call2 e1 pc  no_call2 (if (e) e1 else e2) (Suc (length (compE2 e) + pc))"
      by(auto simp add: no_call2_def)
    hence "?exec ta (if (e) e1 else e2) e1' e' h stk loc (Suc (length (compE2 e) + pc)) xcp h' (Suc (length (compE2 e) + pc'')) stk'' loc'' xcp''"
    using exec' by(cases "τmove1 P h e1'")(auto, (blast intro: Cond_τExecrI2 Cond_τExectI2 exec_move_CondI2)+)
  moreover from bisim'
  have "P,if (e) e1 else e2,h'  (e', xs')  (stk'', loc'', Suc (length (compE2 e) + pc''), xcp'')"
    by(rule bisim1_bisims1.bisim1CondThen)
  ultimately show ?case
    by(auto split: if_split_asm) blast+
next
  case (bisim1CondElse e2 n e2' xs stk loc pc xcp e e1)
  note IH = bisim1CondElse.IH(2)
  note bisim2 = P,e2,h  (e2', xs)  (stk, loc, pc, xcp)
  note bisim = xs. P,e,h  (e, xs)  ([], xs, 0, None)
  note bisim1 = xs. P,e1,h  (e1, xs)  ([], xs, 0, None)
  from IH[OF ‹True,P,t ⊢1 e2',(h, xs) -ta e',(h', xs')] ‹bsok (if (e) e1 else e2) n 
  obtain pc'' stk'' loc'' xcp''
    where bisim': "P,e2,h'  (e', xs')  (stk'', loc'', pc'', xcp'')"
    and exec': "?exec ta e2 e2' e' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
  have "no_call2 e2 pc  no_call2 (if (e) e1 else e2) (Suc (Suc (length (compE2 e) + length (compE2 e1) + pc)))"
      by(auto simp add: no_call2_def)
  hence "?exec ta (if (e) e1 else e2) e2' e' h stk loc (Suc (Suc (length (compE2 e) + length (compE2 e1) + pc))) xcp h' (Suc (Suc (length (compE2 e) + length (compE2 e1) + pc''))) stk'' loc'' xcp''"
    using exec' by(cases "τmove1 P h e2'")(auto, (blast intro: Cond_τExecrI3 Cond_τExectI3 exec_move_CondI3)+)
  moreover from bisim'
  have "P,if (e) e1 else e2,h'  (e', xs')  (stk'', loc'', Suc (Suc (length (compE2 e) + length (compE2 e1) + pc'')), xcp'')"
    by(rule bisim1_bisims1.bisim1CondElse)
  ultimately show ?case
    by(auto split: if_split_asm) blast+
next
  case bisim1CondThrow thus ?case by auto
next
  case (bisim1While1 c n e xs)
  note bisim1 = xs. P,c,h  (c, xs)  ([], xs, 0, None)
  note bisim2 = xs. P,e,h  (e, xs)  ([], xs, 0, None)
  from ‹True,P,t ⊢1 while (c) e,(h, xs) -ta e',(h', xs') show ?case
  proof cases
    case Red1While
    note [simp] = ta = ε e' = if (c) (e;; while (c) e) else unit› h' = h xs' = xs 
    have "τmove1 P h (while (c) e)" by(rule τmove1WhileRed)
    moreover
    have "P,while (c) e,h  (if (c) (e;; while (c) e) else unit, xs)  ([], xs, 0, None)"
      by(rule bisim1_bisims1.bisim1While3[OF bisim1_refl])
    moreover have "sim12_size (while (c) e) > sim12_size e'" by(simp)
    ultimately show ?thesis by auto
  qed
next
  case (bisim1While3 c n c' xs stk loc pc xcp e)
  note IH = bisim1While3.IH(2)
  note bisim1 = P,c,h  (c', xs)  (stk, loc, pc, xcp)
  note bisim2 = xs. P,e,h (e, xs)  ([], xs, 0, None)
  note bsok = ‹bsok (while (c) e) n
  from ‹True,P,t ⊢1 if (c') (e;; while (c) e) else unit,(h, xs) -ta e',(h', xs') show ?case
  proof cases
    case (Cond1Red b')
    note [simp] = e' = if (b') (e;; while (c) e) else unit›
      and red = ‹True,P,t ⊢1 c',(h, xs) -ta b',(h', xs')
    from red have "τmove1 P h (if (c') (e;; while (c) e) else unit) = τmove1 P h c'" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover from red have "call1 (if (c') (e;;while (c) e) else unit) = call1 c'" by auto
    moreover from IH[OF red] bsok
    obtain pc'' stk'' loc'' xcp'' where bisim: "P,c,h'  (b', xs')  (stk'', loc'', pc'', xcp'')"
      and redo: "?exec ta c c' b' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    from bisim
    have "P,while (c) e,h'  (if (b') (e;; while (c) e) else unit, xs')  (stk'', loc'', pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1While3)
    moreover { 
      assume "no_call2 c pc"
      hence "no_call2 (while (c) e) pc" by(auto simp add: no_call2_def) }
    ultimately show ?thesis using redo
      by(auto simp del: call1.simps calls1.simps split: if_split_asm split del: if_split)(blast intro: While_τExecrI1 While_τExectI1 exec_move_WhileI1)+
  next
    case Red1CondT
    note [simp] = c' = true› e' = e;; while (c) e ta = ε h' = h xs' = xs
    from bisim1 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t c h (stk, loc, pc, xcp) ([Bool True], loc, length (compE2 c), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (while (c) e) h (stk, loc, pc, xcp) ([Bool True], loc, length (compE2 c), None)"
      by-(rule While_τExecrI1)
    moreover have "exec_move_a P t (while (c) e) h ([Bool True], loc, length (compE2 c), None) ε h ([], loc, Suc (length (compE2 c)), None)"
      unfolding exec_move_def by(rule exec_instr, auto)
    moreover have "τmove2 (compP2 P) h [Bool True] (while (c) e) (length (compE2 c)) None" by(simp add: τmove2_iff)
    ultimately have "τExec_movet_a P t (while (c) e) h (stk, loc, pc, xcp) ([], loc, Suc (length (compE2 c)), None)"
      by(auto intro: rtranclp_into_tranclp1 τexec_moveI simp add: compP2_def)
    moreover have "τmove1 P h (if (c') (e;; while (c) e) else unit)" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover from bisim1_refl
    have "P, while (c) e, h  (e;; while (c) e, xs)  ([], loc, Suc (length (compE2 c) + 0), None)"
      unfolding s by(rule bisim1While4)
    ultimately show ?thesis by (fastforce)
  next
    case Red1CondF
    note [simp] = c' = false› e' = unit› ta = ε h' = h xs' = xs
    from bisim1 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t c h (stk, loc, pc, xcp) ([Bool False], loc, length (compE2 c), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (while (c) e) h (stk, loc, pc, xcp) ([Bool False], loc, length (compE2 c), None)"
      by-(rule While_τExecrI1)
    moreover have "exec_move_a P t (while (c) e) h ([Bool False], loc, length (compE2 c), None) ε h ([], loc, Suc (Suc (Suc (length (compE2 c) + length (compE2 e)))), None)"
      by(auto intro!: exec_instr simp add: exec_move_def)
    moreover have "τmove2 (compP2 P) h [Bool False] (while (c) e) (length (compE2 c)) None" by(simp add: τmove2_iff)
    ultimately have "τExec_mover_a P t (while (c) e) h (stk, loc, pc, xcp) ([], loc, Suc (Suc (Suc (length (compE2 c) + length (compE2 e)))), None)"
      by(auto intro: rtranclp.rtrancl_into_rtrancl τexec_moveI simp add: compP2_def)
    moreover have "τmove1 P h (if (false) (e;;while (c) e) else unit)" by(rule τmove1CondRed)
    moreover have "P, while (c) e, h  (unit, xs)  ([], loc, (Suc (Suc (Suc (length (compE2 c) + length (compE2 e))))), None)"
      unfolding s by(rule bisim1While7)
    ultimately show ?thesis using s by auto
  next
    case (Cond1Throw a)
    note [simp] = c' = Throw a ta = ε e' = Throw a h' = h xs' = xs
    have τ: "τmove1 P h (if (c') (e;; while (c) e) else unit)" by(auto intro: τmove1CondThrow)
    from bisim1 have "xcp = a  xcp = None" by(auto dest: bisim1_ThrowD)
    thus ?thesis
    proof
      assume [simp]: "xcp = a"
      with bisim1
      have "P, while (c) e, h  (Throw a, xs)  (stk, loc, pc, a)"
        by(auto intro: bisim1_bisims1.bisim1WhileThrow1)
      thus ?thesis using τ by(fastforce)
    next
      assume [simp]: "xcp = None"
      with bisim1 obtain pc'
        where "τExec_mover_a P t c h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        and bisim': "P, c, h  (Throw a, xs)  ([Addr a], loc, pc', a)" and [simp]: "xs = loc"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t (while (c) e) h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        by-(rule While_τExecrI1)
      moreover from bisim'
      have "P, while (c) e, h  (Throw a, xs)  ([Addr a], loc, pc', a)"
        by-(rule bisim1WhileThrow1, auto)
      ultimately show ?thesis using τ by auto
    qed
  qed 
next
  case (bisim1While4 E n e xs stk loc pc xcp c)
  note IH = bisim1While4.IH(2)
  note bisim2 = P,E,h  (e, xs)  (stk, loc, pc, xcp)
  note bisim1 = xs. P,c,h  (c, xs)  ([], xs, 0, None)
  note bsok = ‹bsok (while (c) E) n
  from ‹True,P,t ⊢1 e;; while (c) E,(h, xs) -ta e',(h', xs') show ?case
  proof cases
    case (Seq1Red E')
    note [simp] = e' = E';;while (c) E
      and red = ‹True,P,t ⊢1 e, (h, xs) -ta E', (h', xs')
    from red have τ: "τmove1 P h (e;; while (c) E) = τmove1 P h e" by(auto simp add: τmove1.simps τmoves1.simps)
    with IH[OF red] bsok obtain pc'' stk'' loc'' xcp''
      where bisim: "P,E,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and exec': "?exec ta E e E' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    have "?exec ta (while (c) E) (e;;while (c) E) (E';;while (c) E) h stk loc (Suc (length (compE2 c) + pc)) xcp h' (Suc (length (compE2 c) + pc'')) stk'' loc'' xcp''"
    proof(cases "τmove1 P h (e;; while (c) E)")
      case True
      with exec' show ?thesis using τ by(fastforce intro: While_τExecrI2 While_τExectI2)
    next
      case False
      with exec' τ obtain pc' stk' loc' xcp'
        where e: "τExec_mover_a P t E h (stk, loc, pc, xcp) (stk', loc', pc', xcp')"
        and e': "exec_move_a P t E h (stk', loc', pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'', loc'', pc'', xcp'')"
        and τ': "¬ τmove2 (compP2 P) h stk' E pc' xcp'" 
        and call: "(call1 e = None  no_call2 E pc  pc' = pc  stk' = stk  loc' = loc  xcp' = xcp)" by auto
      from e have "τExec_mover_a P t (while (c) E) h (stk, loc, Suc (length (compE2 c) + pc), xcp) (stk', loc', Suc (length (compE2 c) + pc'), xcp')" by(rule While_τExecrI2)
      moreover
      from e' have "exec_move_a P t (while (c) E) h (stk', loc', Suc (length (compE2 c) + pc'), xcp') (extTA2JVM (compP2 P) ta) h' (stk'', loc'', Suc (length (compE2 c) + pc''), xcp'')"
        by(rule exec_move_WhileI2)
      moreover from τ' e' have "¬ τmove2 (compP2 P) h stk' (while (c) E) (Suc (length (compE2 c) + pc')) xcp'"
        by(auto simp add: τmove2_iff)
      moreover have "call1 (e;; while (c) E) = call1 e" by simp
      moreover have "no_call2 E pc  no_call2 (while (c) E) (Suc (length (compE2 c) + pc))"
        by(auto simp add: no_call2_def)
      ultimately show ?thesis using False call by(auto simp del: split_paired_Ex call1.simps calls1.simps)
    qed
    with bisim τ show ?thesis by auto (blast intro: bisim1_bisims1.bisim1While4)+
  next
    case (Red1Seq v)
    note [simp] = e = Val v ta = ε e' = while (c) E h' = h xs' = xs
    from bisim2 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t E h (stk, loc, pc, xcp) ([v], loc, length (compE2 E), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (while (c) E) h (stk, loc, Suc (length (compE2 c) + pc), xcp) ([v], loc, Suc (length (compE2 c) + length (compE2 E)), None)"
      by-(rule While_τExecrI2)
    moreover
    have "exec_move_a P t (while (c) E) h ([v], loc, Suc (length (compE2 c) + length (compE2 E)), None) ε h ([], loc, Suc (Suc (length (compE2 c) + length (compE2 E))), None)"
      unfolding exec_move_def by(rule exec_instr, auto)
    moreover have "τmove2 (compP2 P) h [v] (while (c) E) (Suc (length (compE2 c) + length (compE2 E))) None" by(simp add: τmove2_iff)
    ultimately have "τExec_movet_a P t (while (c) E) h (stk, loc, Suc (length (compE2 c) + pc), xcp) ([], loc, Suc (Suc (length (compE2 c) + length (compE2 E))), None)"
      by(auto intro: rtranclp_into_tranclp1 τexec_moveI simp add: compP2_def)
    moreover
    have "P, while (c) E, h  (while (c) E, xs)  ([], xs, (Suc (Suc (length (compE2 c) + length (compE2 E)))), None)"
      unfolding s by(rule bisim1While6)
    moreover have "τmove1 P h (e;; while (c) E)" by(auto intro: τmove1SeqRed)
    ultimately show ?thesis using s by(auto)(blast intro: tranclp_into_rtranclp)
  next
    case (Seq1Throw a)
    note [simp] = e = Throw a ta = ε e' = Throw a h' = h xs' = xs
    have τ: "τmove1 P h (e;; while (c) E)" by(auto intro: τmove1SeqThrow)
    from bisim2 have "xcp = a  xcp = None" by(auto dest: bisim1_ThrowD)
    thus ?thesis
    proof
      assume [simp]: "xcp = a"
      with bisim2
      have "P, while (c) E, h  (Throw a, xs)  (stk, loc, Suc (length (compE2 c) + pc), xcp)"
        by(auto intro: bisim1WhileThrow2)
      thus ?thesis using τ by(fastforce)
    next
      assume [simp]: "xcp = None"
      with bisim2 obtain pc'
        where "τExec_mover_a P t E h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        and bisim': "P, E, h  (Throw a, xs)  ([Addr a], loc, pc', a)" and [simp]: "xs = loc"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t (while (c) E) h (stk, loc, Suc (length (compE2 c) + pc), None) ([Addr a], loc, Suc (length (compE2 c) + pc'), a)"
        by-(rule While_τExecrI2)
      moreover from bisim'
      have "P, while (c) E, h  (Throw a, xs)  ([Addr a], loc, Suc (length (compE2 c) + pc'), a)"
        by-(rule bisim1WhileThrow2, auto)
      ultimately show ?thesis using τ by auto
    qed
  qed
next
  case (bisim1While6 c n e xs)
  note bisim1 = xs. P,c,h  (c, xs)  ([], xs, 0, None)
  note bisim2 = xs. P,e,h  (e, xs)  ([], xs, 0, None)
  from ‹True,P,t ⊢1 while (c) e,(h, xs) -ta e',(h', xs') show ?case
  proof cases
    case Red1While
    note [simp] = ta = ε e' = if (c) (e;; while (c) e) else unit› h' = h xs' = xs
    have "τmove1 P h (while (c) e)" by(rule τmove1WhileRed)
    moreover 
    have "P,while (c) e,h  (if (c) (e;; while (c) e) else unit, xs)  ([], xs, 0, None)"
      by(rule bisim1_bisims1.bisim1While3[OF bisim1_refl])
    moreover have "τExec_movet_a P t (while (c) e) h ([], xs, Suc (Suc (length (compE2 c) + length (compE2 e))), None) ([], xs, 0, None)"
      by(rule τExect1step)(auto simp add: exec_move_def τmove2_iff intro: exec_instr)
    ultimately show ?thesis by(fastforce)
  qed
next
  case bisim1While7 thus ?case by fastforce
next
  case bisim1WhileThrow1 thus ?case by auto
next
  case bisim1WhileThrow2 thus ?case by auto
next
  case (bisim1Throw1 E n e xs stk loc pc xcp)
  note IH = bisim1Throw1.IH(2)
  note bisim = P,E,h  (e, xs)  (stk, loc, pc, xcp)
  note red = ‹True,P,t ⊢1 throw e,(h, xs) -ta e',(h', xs')
  note bsok = ‹bsok (throw E) n
  from red show ?case
  proof cases
    case (Throw1Red E')
    note [simp] = e' = throw E'
      and red = ‹True,P,t ⊢1 e, (h, xs) -ta E', (h', xs')
    from red have "τmove1 P h (throw e) = τmove1 P h e" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover have "call1 (throw e) = call1 e" by auto
    moreover from IH[OF red] bsok
    obtain pc'' stk'' loc'' xcp'' where bisim: "P,E,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and redo: "?exec ta E e E' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    from bisim
    have "P,throw E,h'  (throw E', xs')  (stk'', loc'', pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1Throw1)
    moreover { 
      assume "no_call2 E pc"
      hence "no_call2 (throw E) pc" by(auto simp add: no_call2_def) }
    ultimately show ?thesis using redo
      by(auto simp del: call1.simps calls1.simps split: if_split_asm split del: if_split)(blast intro: Throw_τExecrI Throw_τExectI exec_move_ThrowI)+
  next
    case Red1ThrowNull
    note [simp] = e = null› ta = ε e' = THROW NullPointer› h' = h xs' = xs
    from bisim have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t E h (stk, loc, pc, xcp) ([Null], loc, length (compE2 E), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (throw E) h (stk, loc, pc, xcp) ([Null], loc, length (compE2 E), None)"
      by-(rule Throw_τExecrI)
    also have "τExec_movet_a P t (throw E) h ([Null], loc, length (compE2 E), None) ([Null], loc, length (compE2 E), addr_of_sys_xcpt NullPointer)"
      by(rule τExect1step)(auto intro: exec_instr τmove2_τmoves2.intros simp add: exec_move_def)
    also have "P, throw E, h  (THROW NullPointer, xs)  ([Null], loc, length (compE2 E), addr_of_sys_xcpt NullPointer)"
      unfolding s by(rule bisim1ThrowNull)
    moreover have "τmove1 P h (throw e)" by(auto intro: τmove1ThrowNull)
    ultimately show ?thesis by auto
  next
    case (Throw1Throw a)
    note [simp] = e = Throw a ta = ε e' = Throw a h' = h xs' = xs
    have τ: "τmove1 P h (throw (Throw a))" by(rule τmove1ThrowThrow)
    from bisim have "xcp = a  xcp = None" by(auto dest: bisim1_ThrowD)
    thus ?thesis
    proof
      assume "xcp = a"
      with bisim show ?thesis using τ by(fastforce intro: bisim1ThrowThrow)
    next
      assume [simp]: "xcp = None"
      from bisim obtain pc'
        where "τExec_mover_a P t E h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        and bisim: "P, E, h  (Throw a, xs)  ([Addr a], loc, pc', a)" and s: "xs = loc"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t (throw E) h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        by -(rule Throw_τExecrI)
      moreover from bisim have "P, throw E, h  (Throw a, xs)  ([Addr a], loc, pc', a)"
        by(rule bisim1ThrowThrow)
      ultimately show ?thesis using τ by auto
    qed
  qed
next
  case bisim1Throw2 thus ?case by auto
next
  case bisim1ThrowNull thus ?case by auto
next
  case bisim1ThrowThrow thus ?case by auto
next
  case (bisim1Try E n e xs stk loc pc xcp e2 C' V)
  note IH = bisim1Try.IH(2)
  note bisim1 = P,E,h  (e, xs)  (stk, loc, pc, xcp)
  note bisim2 = xs. P,e2,h  (e2, xs)  ([], xs, 0, None)
  note red = ‹True,P,t ⊢1 try e catch(C' V) e2,(h, xs) -ta e',(h', xs')
  note bsok = ‹bsok (try E catch(C' V) e2) n
  from red show ?case
  proof cases
    case (Try1Red E')
    note [simp] = e' = try E' catch(C' V) e2
      and red = ‹True,P,t ⊢1 e, (h, xs) -ta E', (h', xs')
    from red have "τmove1 P h (try e catch(C' V) e2) = τmove1 P h e" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover have "call1 (try e catch(C' V) e2) = call1 e" by auto
    moreover from IH[OF red] bsok
    obtain pc'' stk'' loc'' xcp'' where bisim: "P,E,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and redo: "?exec ta E e E' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    from bisim 
    have "P,try E catch(C' V) e2,h'  (try E' catch(C' V) e2, xs')  (stk'', loc'', pc'', xcp'')"
      by(rule bisim1_bisims1.bisim1Try)
    moreover { 
      assume "no_call2 E pc"
      hence "no_call2 (try E catch(C' V) e2) pc" by(auto simp add: no_call2_def) }
    ultimately show ?thesis using redo
      by(auto simp del: call1.simps calls1.simps split: if_split_asm split del: if_split)(blast intro: Try_τExecrI1 Try_τExectI1 exec_move_TryI1)+
  next
    case (Red1Try v)
    note [simp] = e = Val v ta = ε e' = Val v h' = h xs' = xs
    have τ: "τmove1 P h (try Val v catch(C' V) e2)" by(rule τmove1TryRed)
    from bisim1 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t E h (stk, loc, pc, xcp) ([v], loc, length (compE2 E), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (try E catch(C' V) e2) h (stk, loc, pc, xcp) ([v], loc, length (compE2 E), None)"
      by-(rule Try_τExecrI1)
    also have "τExec_mover_a P t (try E catch(C' V) e2) h ([v], loc, length (compE2 E), None) ([v], loc, length (compE2 (try E catch(C' V) e2)), None)"
      by(rule τExecr1step)(auto intro: exec_instr simp add: exec_move_def τmove2_iff)
    also (rtranclp_trans)
    have "P, try E catch(C' V) e2, h  (Val v, xs)  ([v], xs, length (compE2 (try E catch(C' V) e2)), None)"
      by(rule bisim1Val2) simp
    ultimately show ?thesis using s τ by(auto)
  next
    case (Red1TryCatch a D)
    hence [simp]: "e = Throw a" "ta = ε" "e' = {V:Class C'=None; e2}" "h' = h" "xs' = xs[V := Addr a]"
      and ha: "typeof_addr h a = Class_type D" and sub: "P  D * C'"
      and V: "V < length xs" by auto
    from bisim1 have [simp]: "xs = loc" and xcp: "xcp = a  xcp = None" 
      by(auto dest: bisim1_ThrowD)
    from xcp have "τExec_mover_a P t (try E catch(C' V) e2) h (stk, loc, pc, xcp) ([Addr a], loc, Suc (length (compE2 E)), None)"
    proof
      assume [simp]: "xcp = a"
      with bisim1 have "match_ex_table (compP2 P) (cname_of h a) pc (compxE2 E 0 0) = None"
        by(auto dest: bisim1_xcp_Some_not_caught[where pc'=0] simp add: compP2_def)
      moreover from bisim1 have "pc < length (compE2 E)"
        by(auto dest: bisim1_ThrowD)
      ultimately show ?thesis using ha sub unfolding xcp = a
        by-(rule τExecr1step[unfolded exec_move_def, OF exec_catch[where d=0, simplified]],
            auto simp add: τmove2_iff matches_ex_entry_def compP2_def match_ex_table_append_not_pcs cname_of_def)
    next
      assume [simp]: "xcp = None"
      with bisim1 obtain pc' where "τExec_mover_a P t E h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        and bisim': "P, E, h  (Throw a, xs)  ([Addr a], loc, pc', a)" and s: "xs = loc"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t (try E catch(C' V) e2) h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        by-(rule Try_τExecrI1)
      also from bisim' have "match_ex_table (compP2 P) (cname_of h a) pc' (compxE2 E 0 0) = None"
        by(auto dest: bisim1_xcp_Some_not_caught[where pc'=0] simp add: compP2_def)
      with ha sub bisim1_ThrowD[OF bisim']
      have "τExec_mover_a P t (try E catch(C' V) e2) h ([Addr a], loc, pc', a) ([Addr a], loc, Suc (length (compE2 E)), None)"
        by-(rule τExecr1step[unfolded exec_move_def, OF exec_catch[where d=0, simplified]], auto simp add: τmove2_iff matches_ex_entry_def compP2_def match_ex_table_append_not_pcs cname_of_def)
      finally (rtranclp_trans) show ?thesis by simp
    qed
    also let ?pc' = "Suc (length (compE2 E))" from V
    have exec: "τExec_movet_a P t (try E catch(C' V) e2) h ([Addr a], loc, ?pc', None) ([], loc[V := Addr a], Suc ?pc', None)"
      by-(rule τExect1step[unfolded exec_move_def, OF exec_instr], auto simp add: nth_append intro: τmove2_τmoves2.intros)
    also (rtranclp_tranclp_tranclp)
    have bisim': "P,try E catch(C' V) e2, h  ({V:Class C'=None; e2}, xs[V := Addr a])  ([], loc[V := Addr a], Suc ?pc', None)"
      unfolding xs = loc by(rule bisim1TryCatch2[OF bisim1_refl, simplified]) 
    moreover have "τmove1 P h (try Throw a catch(C' V) e2)" by(rule τmove1TryThrow)
    ultimately show ?thesis by(auto)(blast intro: tranclp_into_rtranclp)
  next
    case (Red1TryFail a D)
    hence [simp]: "e = Throw a" "ta = ε" "e' = Throw a" "h' = h" "xs' = xs"
      and ha: "typeof_addr h a = Class_type D" and sub: "¬ P  D * C'" by auto
    have τ: "τmove1 P h (try Throw a catch(C' V) e2)" by(rule τmove1TryThrow)
    from bisim1 have [simp]:  "xs = loc" and "xcp = a  xcp = None" by(auto dest: bisim1_ThrowD)
    from bisim1 have pc: "pc  length (compE2 E)" by(rule bisim1_pc_length_compE2)
    from xcp = a  xcp = None› show ?thesis
    proof
      assume [simp]: "xcp = a"
      with bisim1 ha sub
      have "P,try E catch(C' V) e2,h  (Throw a, xs)  (stk, loc, pc, a)"
        by(auto intro: bisim1TryFail)
      thus ?thesis using τ by(fastforce)
    next
      assume [simp]: "xcp = None"
      with bisim1 obtain pc' 
        where "τExec_mover_a P t E h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        and bisim': "P, E, h  (Throw a, xs)  ([Addr a], loc, pc', a)"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t (try E catch(C' V) e2) h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        by-(rule Try_τExecrI1)
      moreover from bisim' ha sub
      have "P,try E catch(C' V) e2,h  (Throw a, xs)  ([Addr a], loc, pc', a)"
        by(auto intro: bisim1TryFail)
      ultimately show ?thesis using τ by auto
    qed
  qed
next
  case (bisim1TryCatch1 e n a xs stk loc pc D C' e2 V)
  note bisim1 = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  note bisim2 = xs. P,e2,h  (e2, xs)  ([], xs, 0, None)
  note IH2 = bisim1TryCatch1.IH(6)
  note ha = typeof_addr h a = Class_type D
  note sub = P  D * C'
  note red = ‹True,P,t ⊢1 {V:Class C'=None; e2},(h, xs[V := Addr a]) -ta e',(h', xs')
  note bsok = ‹bsok (try e catch(C' V) e2) n
  from bisim1 have [simp]: "xs = loc" by(auto dest: bisim1_ThrowD)
  from red show ?case
  proof cases
    case (Block1Red E')
    note [simp] = e' = {V:Class C'=None; E'}
      and red = ‹True,P,t ⊢1 e2, (h, xs[V := Addr a]) -ta E', (h', xs')
    from red have τ: "τmove1 P h {V:Class C'=None; e2} = τmove1 P h e2" by(auto simp add: τmove1.simps τmoves1.simps)
    have exec: "τExec_mover_a P t (try e catch(C' V) e2) h ([Addr a], xs, Suc (length (compE2 e) + 0), None) ([], xs[V := Addr a], Suc (Suc (length (compE2 e) + 0)), None)"
      by -(rule τExecr1step, auto simp add: exec_move_def τmove2_iff intro: exec_instr)
    moreover from IH2[OF red] bsok obtain pc'' stk'' loc'' xcp''
      where bisim': "P,e2,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and exec': "?exec ta e2 e2 E' h [] (xs[V := Addr a]) 0 None h' pc'' stk'' loc'' xcp''" by auto
    have "?exec ta (try e catch(C' V) e2) {V:Class C'=None; e2} {V:Class C'=None; E'} h [] (xs[V := Addr a]) (Suc (Suc (length (compE2 e))))  None h' (Suc (Suc (length (compE2 e) + pc''))) stk'' loc'' xcp''"
    proof(cases "τmove1 P h {V:Class C'=None; e2}")
      case True with τ exec' show ?thesis
        by(fastforce dest: Try_τExecrI2 Try_τExectI2 simp del: compE2.simps compEs2.simps)
    next
      case False
      with τ exec' obtain pc' stk' loc' xcp'
        where e: "τExec_mover_a P t e2 h ([], xs[V := Addr a], 0, None) (stk', loc', pc', xcp')"
        and e': "exec_move_a P t e2 h (stk', loc', pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'', loc'', pc'', xcp'')"
        and τ': "¬ τmove2 (compP2 P) h stk' e2 pc' xcp'" 
        and call: "call1 e2 = None  no_call2 e2 0  pc' = 0  stk' = []  loc' = xs[V := Addr a]  xcp' = None" by auto
      from e have "τExec_mover_a P t (try e catch(C' V) e2) h ([], xs[V := Addr a], Suc (Suc (length (compE2 e) + 0)), None) (stk', loc', Suc (Suc (length (compE2 e) + pc')), xcp')"
        by(rule Try_τExecrI2)
      moreover from e'
      have "exec_move_a P t (try e catch(C' V) e2) h (stk', loc', Suc (Suc (length (compE2 e) + pc')), xcp') (extTA2JVM (compP2 P) ta) h' (stk'', loc'', Suc (Suc (length (compE2 e) + pc'')), xcp'')"
        by(rule exec_move_TryI2)
      moreover from τ' have "τmove2 (compP2 P) h stk' (try e catch(C' V) e2) (Suc (Suc (length (compE2 e) + pc'))) xcp'  False"
        by(simp add: τmove2_iff)
      moreover have "call1 {V:Class C'=None; e2} = call1 e2" by simp
      moreover have "no_call2 e2 0  no_call2 (try e catch(C' V) e2) (Suc (Suc (length (compE2 e))))"
        by(auto simp add: no_call2_def)
      ultimately show ?thesis using False call by(auto simp del: split_paired_Ex call1.simps calls1.simps) blast
    qed
    moreover from bisim' 
    have "P, try e catch(C' V) e2, h'  ({V:Class C'=None; E'}, xs')  (stk'', loc'', Suc (Suc (length (compE2 e) + pc'')), xcp'')"
      by(rule bisim1TryCatch2)
    moreover have "no_call2 (try e catch(C' V) e2) (Suc (length (compE2 e)))" by(simp add: no_call2_def)
    ultimately show ?thesis using τ 
      by auto(blast intro: rtranclp_trans rtranclp_tranclp_tranclp)+
  next
    case (Red1Block u)
    note [simp] = e2 = Val u ta = ε e' = Val u h' = h xs' = xs[V := Addr a]
    have "τExec_mover_a P t (try e catch(C' V) Val u) h ([Addr a], xs, Suc (length (compE2 e) + 0), None) ([], xs[V := Addr a], Suc (Suc (length (compE2 e) + 0)), None)"
      by -(rule τExecr1step, auto simp add: exec_move_def τmove2_iff intro: exec_instr)
    also have "τExec_mover_a P t (try e catch(C' V) Val u) h ([], xs[V := Addr a], Suc (Suc (length (compE2 e) + 0)), None) ([u], xs[V := Addr a], Suc (Suc (length (compE2 e) + 1)), None)"
      by -(rule Try_τExecrI2[OF τExecr1step[unfolded exec_move_def, OF exec_instr]], auto simp add: τmove2_iff)
    also (rtranclp_trans)
    have "P, try e catch(C' V) Val u, h  (Val u, xs[V := Addr a])  ([u], xs[V := Addr a], length (compE2 (try e catch(C' V) Val u)), None)"
      by(rule bisim1Val2) simp
    moreover have "τmove1 P h {V:Class C'=None; Val u}" by(rule τmove1BlockRed)
    ultimately show ?thesis by(auto)
  next
    case (Block1Throw a')
    note [simp] = e2 = Throw a' h' = h ta = ε e' = Throw a' xs' = xs[V := Addr a]
    have "τmove1 P h {V:Class C'=None; Throw a'}" by(rule τmove1BlockThrow)
    moreover have "τExec_mover_a P t (try e catch(C' V) e2) h ([Addr a], loc, Suc (length (compE2 e)), None)
                                 ([Addr a'], xs', Suc (Suc (Suc (length (compE2 e)))), a')"
      by(rule τExecr3step)(auto simp add: exec_move_def exec_meth_instr τmove2_iff)
    moreover have "P, try e catch(C' V) Throw a', h  (Throw a', xs')  ([Addr a'], xs', Suc (Suc (length (compE2 e) + length (compE2 (addr a')))), a')"
      by(rule bisim1TryCatchThrow)(rule bisim1Throw2)
    ultimately show ?thesis by auto
  qed
next
  case (bisim1TryCatch2 e2 n e2' xs stk loc pc xcp e C' V)
  note bisim2 = P,e2,h  (e2', xs)  (stk, loc, pc, xcp)
  note bisim1 = xs. P,e,h  (e, xs)  ([], xs, 0, None)
  note IH2 = bisim1TryCatch2.IH(2)
  note red = ‹True,P,t ⊢1 {V:Class C'=None; e2'},(h, xs) -ta e',(h', xs')
  note bsok = ‹bsok (try e catch(C' V) e2) n
  from red show ?case
  proof cases
    case (Block1Red E')
    note [simp] = e' = {V:Class C'=None; E'}
      and red = ‹True,P,t ⊢1 e2', (h, xs) -ta E', (h', xs')
    from red have τ: "τmove1 P h {V:Class C'=None; e2'} = τmove1 P h e2'" by(auto simp add: τmove1.simps τmoves1.simps)
    from IH2[OF red] bsok obtain pc'' stk'' loc'' xcp''
      where bisim': "P,e2,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and exec': "?exec ta e2 e2' E' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    have "?exec ta (try e catch(C' V) e2) {V:Class C'=None; e2'} {V:Class C'=None; E'} h stk loc (Suc (Suc (length (compE2 e) + pc))) xcp h' (Suc (Suc (length (compE2 e) + pc''))) stk'' loc'' xcp''"
    proof (cases "τmove1 P h {V:Class C'=None; e2'}")
      case True with τ exec' show ?thesis by(auto intro: Try_τExecrI2 Try_τExectI2)
    next
      case False
      with τ exec' obtain pc' stk' loc' xcp'
        where e: "τExec_mover_a P t e2 h (stk, loc, pc, xcp) (stk', loc', pc', xcp')"
        and e': "exec_move_a P t e2 h (stk', loc', pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'', loc'', pc'', xcp'')"
        and τ': "¬ τmove2 (compP2 P) h stk' e2 pc' xcp'" 
        and call: "call1 e2' = None  no_call2 e2 pc  pc' = pc  stk' = stk  loc' = loc  xcp' = xcp" by auto
      from e have "τExec_mover_a P t (try e catch(C' V) e2) h (stk, loc, Suc (Suc (length (compE2 e) + pc)), xcp) (stk', loc', Suc (Suc (length (compE2 e) + pc')), xcp')"
        by(rule Try_τExecrI2)
      moreover from e'
      have "exec_move_a P t (try e catch(C' V) e2) h (stk', loc', Suc (Suc (length (compE2 e) + pc')), xcp') (extTA2JVM (compP2 P) ta) h' (stk'', loc'', Suc (Suc (length (compE2 e) +  pc'')), xcp'')"
        by(rule exec_move_TryI2)
      moreover from τ' have "τmove2 (compP2 P) h stk' (try e catch(C' V) e2) (Suc (Suc (length (compE2 e) + pc'))) xcp'  False"
        by(simp add: τmove2_iff)
      moreover have "call1 {V:Class C'=None; e2'} = call1 e2'" by simp
      moreover have "no_call2 e2 pc  no_call2 (try e catch(C' V) e2) (Suc (Suc (length (compE2 e) + pc)))"
        by(auto simp add: no_call2_def)
      ultimately show ?thesis using False call by(auto simp del: split_paired_Ex call1.simps calls1.simps)
    qed
    moreover from bisim'
    have "P, try e catch(C' V) e2, h'  ({V:Class C'=None; E'}, xs')  (stk'', loc'', Suc (Suc (length (compE2 e) + pc'')), xcp'')"
      by(rule bisim1_bisims1.bisim1TryCatch2)
    ultimately show ?thesis using τ by auto blast+
  next
    case (Red1Block u)
    note [simp] = e2' = Val u ta = ε e' = Val u h' = h xs' = xs
    from bisim2 have s: "xcp = None" "xs = loc"
      and "τExec_mover_a P t e2 h (stk, loc, pc, xcp) ([u], loc, length (compE2 e2), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_mover_a P t (try e catch(C' V) e2) h (stk, loc, Suc (Suc (length (compE2 e) + pc)), xcp) ([u], loc, Suc (Suc (length (compE2 e) + length (compE2 e2))), None)"
      by -(rule Try_τExecrI2)
    moreover
    have "P, try e catch(C' V) e2, h  (Val u, xs)  ([u], xs, length (compE2 (try e catch(C' V) e2)), None)"
      by(rule bisim1Val2) simp
    moreover have "τmove1 P h {V:Class C'=None; Val u}" by(rule τmove1BlockRed)
    ultimately show ?thesis using s by auto
  next
    case (Block1Throw a)
    note [simp] = e2' = Throw a ta = ε e' = Throw a h' = h xs' = xs
    have τ: "τmove1 P h {V:Class C'=None; e2'}"  by(auto simp add: τmove1.simps τmoves1.simps)
    from bisim2 have "xcp = a  xcp = None" by(auto dest: bisim1_ThrowD)
    thus ?thesis
    proof
      assume [simp]: "xcp = a"
      with bisim2 
      have "P, try e catch(C' V) e2, h  (Throw a, xs)  (stk, loc, Suc (Suc (length (compE2 e) + pc)), xcp)"
        by(auto intro: bisim1TryCatchThrow)
      thus ?thesis using τ by(fastforce)
    next
      assume [simp]: "xcp = None"
      with bisim2 obtain pc' 
        where "τExec_mover_a P t e2 h (stk, loc, pc, None) ([Addr a], loc, pc', a)"
        and bisim': "P, e2, h  (Throw a, xs)  ([Addr a], loc, pc', a)" and [simp]: "xs = loc"
        by(auto dest: bisim1_Throw_τExec_mover)
      hence "τExec_mover_a P t (try e catch(C' V) e2) h (stk, loc, Suc (Suc (length (compE2 e) + pc)), None) ([Addr a], loc, Suc (Suc (length (compE2 e) + pc')), a)"
        by-(rule Try_τExecrI2)
      moreover from bisim'
      have "P, try e catch(C' V) e2, h  (Throw a, xs)  ([Addr a], loc, Suc (Suc (length (compE2 e) + pc')), a)"
        by(rule bisim1TryCatchThrow)
      ultimately show ?thesis using τ by auto
    qed
  qed
next
  case bisim1TryFail thus ?case by auto
next
  case bisim1TryCatchThrow thus ?case by auto
next
  case bisims1Nil thus ?case by(auto elim!: reds1.cases)
next
  case (bisims1List1 E n e xs stk loc pc xcp es)
  note IH1 = bisims1List1.IH(2)
  note IH2 = bisims1List1.IH(4)
  note bisim1 = P,E,h  (e, xs)  (stk, loc, pc, xcp)
  note bisim2 = xs. P,es,h  (es, xs) [↔] ([], xs, 0, None)
  note bsok = ‹bsoks (E # es) n
  from ‹True,P,t ⊢1 e # es,(h, xs) [-ta→] es',(h', xs') show ?case
  proof cases
    case (List1Red1 E')
    note [simp] = es' = E' # es
      and red = ‹True,P,t ⊢1 e,(h, xs) -ta E',(h', xs')
    from red have τ: "τmoves1 P h (e # es) = τmove1 P h e" by(auto simp add: τmove1.simps τmoves1.simps)
    moreover from IH1[OF red] bsok
    obtain pc'' stk'' loc'' xcp'' where bisim: "P,E,h'  (E', xs')  (stk'', loc'', pc'', xcp'')"
      and redo: "?exec ta E e E' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    from bisim 
    have "P,E#es,h'  (E'#es, xs') [↔] (stk'', loc'', pc'', xcp'')"
      by(rule bisim1_bisims1.bisims1List1)
    moreover { 
      assume "no_call2 E pc"
      hence "no_calls2 (E # es) pc  pc = length (compE2 E)" by(auto simp add: no_call2_def no_calls2_def) }
    moreover from red have "calls1 (e # es) = call1 e" by auto
    ultimately show ?thesis using redo
      apply(auto simp add: exec_move_def exec_moves_def simp del: call1.simps calls1.simps split: if_split_asm split del: if_split)
      apply(blast intro: τExec_mover_τExec_movesr τExec_movet_τExec_movest intro!: bisim1_bisims1.bisims1List1 elim: τmoves2.cases)+
      done
  next
    case (List1Red2 ES' v)
    note [simp] = es' = Val v # ES' e = Val v
      and red = ‹True,P,t ⊢1 es,(h, xs) [-ta→] ES',(h', xs')
    from bisim1 have s: "xs = loc" "xcp = None"
      and exec1: "τExec_mover_a P t E h (stk, loc, pc, xcp) ([v], loc, length (compE2 E), None)"
      by(auto dest: bisim1Val2D1)
    hence "τExec_movesr_a P t (E # es) h (stk, loc, pc, xcp) ([v], loc, length (compE2 E), None)"
      by -(rule τExec_mover_τExec_movesr)
    moreover from IH2[OF red] bsok obtain pc'' stk'' loc'' xcp''
      where bisim': "P,es,h'  (ES', xs') [↔] (stk'', loc'', pc'', xcp'')"
      and exec': "?execs ta es es ES' h [] xs 0 None h' pc'' stk'' loc'' xcp''" by auto
    have τ: "τmoves1 P h (Val v # es) = τmoves1 P h es" by(auto simp add: τmove1.simps τmoves1.simps)
    have "?execs ta (E # es) (Val v # es) (Val v # ES') h [v] xs (length (compE2 E)) None h' (length (compE2 E) +  pc'') (stk'' @ [v]) loc'' xcp''"
    proof(cases "τmoves1 P h (Val v # es)")
      case True with τ exec' show ?thesis
        using append_τExec_movesr[of "[v]" "[E]" _ P t es h "[]" xs 0 None stk'' loc'' pc'' xcp'']
          append_τExec_movest[of "[v]" "[E]" _ P t es h "[]" xs 0 None stk'' loc'' pc'' xcp''] by auto 
    next
      case False with τ exec' obtain pc' stk' loc' xcp'
        where e: "τExec_movesr_a P t es h ([], xs, 0, None) (stk', loc', pc', xcp')"
        and e': "exec_moves_a P t es h (stk', loc', pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'', loc'', pc'', xcp'')"
        and τ': "¬ τmoves2 (compP2 P) h stk' es pc' xcp'" 
        and call: "calls1 es = None  no_calls2 es 0  pc' = 0  stk' = []  loc' = xs  xcp' = None" by auto
      from append_τExec_movesr[OF _ e, where vs="[v]" and es' = "[E]"]
      have "τExec_movesr_a P t (E # es) h ([v], xs, length (compE2 E), None) (stk' @ [v], loc', length (compE2 E) + pc', xcp')" by simp
      moreover from append_exec_moves[OF _ e', of "[v]" "[E]"]
      have "exec_moves_a P t (E # es) h (stk' @ [v], loc', length (compE2 E) + pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'' @ [v], loc'', length (compE2 E) + pc'', xcp'')"
        by simp
      moreover from τ' e'
      have "τmoves2 (compP2 P) h (stk' @ [v]) (E # es) (length (compE2 E) + pc') xcp'  False"
        by(auto simp add: τmoves2_iff τinstr_stk_drop_exec_moves)
      moreover have "calls1 (Val v # es) = calls1 es" by simp
      moreover have "no_calls2 es 0  no_calls2 (E # es) (length (compE2 E))"
        by(auto simp add: no_calls2_def)
      ultimately show ?thesis using False call by(auto simp del: split_paired_Ex call1.simps calls1.simps) blast
    qed
    moreover from bisim' 
    have "P,E # es,h'  (Val v # ES', xs') [↔] (stk'' @ [v], loc'', length (compE2 E) + pc'', xcp'')"
      by(rule bisim1_bisims1.bisims1List2)
    moreover from bisim1 have "pc  length (compE2 E)  no_calls2 (E # es) pc"
      by(auto simp add: no_calls2_def dest: bisim_Val_pc_not_Invoke bisim1_pc_length_compE2)
    ultimately show ?thesis using τ exec1 s
      apply(auto simp del: split_paired_Ex call1.simps calls1.simps split: if_split_asm split del: if_split)
      apply(blast intro: τExec_movesr_trans|fastforce elim!: τExec_movesr_trans simp del: split_paired_Ex call1.simps calls1.simps)+
      done
  qed
next
  case (bisims1List2 ES n es xs stk loc pc xcp e v)
  note IH2 = bisims1List2.IH(2)
  note bisim1 = xs. P,e,h  (e, xs)  ([], xs, 0, None)
  note bisim2 = P,ES,h  (es, xs) [↔] (stk, loc, pc, xcp)
  note bsok = ‹bsoks (e # ES) n
  from ‹True,P,t ⊢1 Val v # es,(h, xs) [-ta→] es',(h', xs') show ?case
  proof cases
    case (List1Red2 ES')
    note [simp] = es' = Val v # ES'
      and red = ‹True,P,t ⊢1 es,(h, xs) [-ta→] ES',(h', xs')
    from IH2[OF red] bsok obtain pc'' stk'' loc'' xcp''
      where bisim': "P,ES,h'  (ES', xs') [↔] (stk'', loc'', pc'', xcp'')"
      and exec': "?execs ta ES es ES' h stk loc pc xcp h' pc'' stk'' loc'' xcp''" by auto
    have τ: "τmoves1 P h (Val v # es) = τmoves1 P h es" by(auto simp add: τmove1.simps τmoves1.simps)
    have "?execs ta (e # ES) (Val v # es) (Val v # ES') h (stk @ [v]) loc (length (compE2 e) + pc) xcp h' (length (compE2 e) +  pc'') (stk'' @ [v]) loc'' xcp''"
    proof(cases "τmoves1 P h (Val v # es)")
      case True with τ exec' show ?thesis
        using append_τExec_movesr[of "[v]" "[e]" _ P t ES h stk]
          append_τExec_movest[of "[v]" "[e]" _ P t ES h stk] by auto
    next
      case False with τ exec' obtain pc' stk' loc' xcp'
        where e: "τExec_movesr_a P t ES h (stk, loc, pc, xcp) (stk', loc', pc', xcp')"
        and e': "exec_moves_a P t ES h (stk', loc', pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'', loc'', pc'', xcp'')"
        and τ': "¬ τmoves2 (compP2 P) h stk' ES pc' xcp'" 
        and call: "calls1 es = None  no_calls2 ES pc  pc' = pc  stk' = stk  loc' = loc  xcp' = xcp" by auto
      from append_τExec_movesr[OF _ e, where vs="[v]" and es' = "[e]"]
      have "τExec_movesr_a P t (e # ES) h (stk @ [v], loc, length (compE2 e) + pc, xcp) (stk' @ [v], loc', length (compE2 e) + pc', xcp')" by simp
      moreover from append_exec_moves[OF _ e', of "[v]" "[e]"]
      have "exec_moves_a P t (e # ES) h (stk' @ [v], loc', length (compE2 e) + pc', xcp') (extTA2JVM (compP2 P) ta) h' (stk'' @ [v], loc'', length (compE2 e) + pc'', xcp'')" by simp
      moreover from τ' e'
      have "τmoves2 (compP2 P) h (stk' @ [v]) (e # ES) (length (compE2 e) + pc') xcp'  False"
        by(auto simp add: τmoves2_iff τinstr_stk_drop_exec_moves)
      moreover have "calls1 (Val v # es) = calls1 es" by simp
      moreover have "no_calls2 ES pc  no_calls2 (e # ES) (length (compE2 e) + pc)"
        by(auto simp add: no_calls2_def)
      ultimately show ?thesis using False call by(auto simp del: split_paired_Ex call1.simps calls1.simps) 
    qed
    moreover from bisim'
    have "P,e # ES,h'  (Val v # ES', xs') [↔] (stk'' @ [v], loc'', length (compE2 e) + pc'', xcp'')"
      by(rule bisim1_bisims1.bisims1List2)
    ultimately show ?thesis using τ by auto blast+
  qed auto
qed

end


context J1_JVM_conf_read begin

lemma exec_1_simulates_Red1_τ:
  assumes wf: "wf_J1_prog P"
  and Red1: "True,P,t ⊢1 (e, xs)/exs, h -ta (e', xs')/exs', h"
  and bisim: "bisim1_list1 t h (e, xs) exs xcp frs"
  and τ: "τMove1 P h ((e, xs), exs)"
  shows "xcp' frs'. (if sim12_size e' < sim12_size e then τExec_1_dr else τExec_1_dt) (compP2 P) t (xcp, h, frs) (xcp', h, frs')  bisim1_list1 t h (e',xs') exs' xcp' frs'"
proof -
  from wf have wt: "wf_jvm_progcompTP P (compP2 P)" by(rule wt_compTP_compP2)
  from Red1 show ?thesis
  proof(cases)
    case (red1Red TA)
    note [simp] = ta = extTA2J1 P TA exs' = exs
      and red = ‹True,P,t ⊢1 e,(h, xs) -TA e',(h, xs')
    from τ red have τ': "τmove1 P h e" by(auto elim: red1_cases)
    from bisim show ?thesis
    proof(cases)
      case (bl1_Normal stk loc C M pc FRS Ts T body D)
      hence [simp]: "frs = (stk, loc, C, M, pc) # FRS"
        and conf: "compTP P  t: (xcp, h, frs) "
        and sees: "P  C sees M: TsT = body in D"
        and bisim: "P,blocks1 0 (Class D#Ts) body,h  (e, xs)  (stk, loc, pc, xcp)"
        and bisims: "list_all2 (bisim1_fr P h) exs FRS"
        and lenxs: "max_vars e  length xs"
        by auto
      from sees wf have "bsok (blocks1 0 (Class D # Ts) body) 0"
        by(auto dest!: sees_wf_mdecl WT1_expr_locks simp add: wf_J1_mdecl_def wf_mdecl_def bsok_def)
      from exec_instr_simulates_red1[OF wf bisim red this] τ' obtain pc' stk' loc' xcp'
        where exec: "(if sim12_size e' < sim12_size e then τExec_mover_a else τExec_movet_a) P t body h (stk, loc, pc, xcp) (stk', loc', pc', xcp')"
        and b': "P,blocks1 0 (Class D#Ts) body,h  (e', xs')  (stk', loc', pc', xcp')"
        by(auto split: if_split_asm simp del: blocks1.simps)
      from exec sees have "(if sim12_size e' < sim12_size e then τExec_1r else τExec_1t) (compP2 P) t (xcp, h, frs) (xcp', h, (stk', loc', C, M, pc') # FRS)"
        by(auto intro: τExec_mover_τExec_1r τExec_movet_τExec_1t)
      from wt this conf have execd: "(if sim12_size e' < sim12_size e then τExec_1_dr else τExec_1_dt) (compP2 P) t (xcp, h, frs) (xcp', h, (stk', loc', C, M, pc') # FRS)"
        by(auto intro: τExec_1r_τExec_1_dr τExec_1t_τExec_1_dt)
      moreover from wt execd conf
      have "compTP P  t: (xcp', h, (stk', loc', C, M, pc') # FRS) "
        by(auto intro: τExec_1_dr_preserves_correct_state τExec_1_dt_preserves_correct_state split: if_split_asm)
      hence "bisim1_list1 t h (e', xs') exs xcp' ((stk', loc', C, M, pc') # FRS)"
        using sees b' 
      proof
        from red have "max_vars e'  max_vars e" by(rule red1_max_vars)
        with red1_preserves_len[OF red] lenxs
        show "max_vars e'  length xs'" by simp
      qed fact
      hence "bisim1_list1 t h (e',xs') exs' xcp' ((stk', loc', C, M, pc') # FRS)" by simp
      ultimately show ?thesis by blast
    qed(insert red, auto elim: red1_cases)
  next
    case (red1Call a' M' vs' U' Ts' T' body' D')
    hence [simp]: "ta = ε"
      and exs' [simp]: "exs' = (e, xs) # exs"
      and e': "e' = blocks1 0 (Class D'#Ts') body'"
      and xs': "xs' = Addr a' # vs' @ replicate (max_vars body') undefined_value"
      and ha': "typeof_addr h a' = U'"
      and call: "call1 e = (a', M', vs')" by auto
    note sees' = P  class_type_of U' sees M': Ts'T' = body' in D'
    note lenvs'Ts' = ‹length vs' = length Ts'
    from ha' sees_method_decl_above[OF sees'] 
    have conf: "P,h  Addr a' :≤ ty_of_htype U'" by(auto simp add: conf_def)
    note wt = wt_compTP_compP2[OF wf]
    from bisim show ?thesis
    proof(cases)
      case (bl1_Normal stk loc C M pc FRS Ts T body D)
      hence [simp]: "frs = (stk, loc, C, M, pc) # FRS"
        and conf: "compTP P  t: (xcp, h, frs) "
        and sees: "P  C sees M: TsT = body in D"
        and bisim: "P,blocks1 0 (Class D#Ts) body,h  (e, xs)  (stk, loc, pc, xcp)"
        and bisims: "list_all2 (bisim1_fr P h) exs FRS" 
        and lenxs: "max_vars e  length xs" by auto
      from call bisim have [simp]: "xcp = None" by(cases xcp, auto dest: bisim1_call_xcpNone)
      from bisim have b: "P,blocks1 0 (Class D#Ts) body,h  (e, xs)  (stk, loc, pc, None)" by simp
      from bisim have lenloc: "length xs = length loc" by(rule bisim1_length_xs)
      from sees have sees'': "compP2 P  C sees M:TsT = (max_stack body, max_vars body, compE2 body @ [Return], compxE2 body 0 0) in D"
        unfolding compP2_def compMb2_def Let_def by(auto dest: sees_method_compP)
      from sees wf have "¬ contains_insync (blocks1 0 (Class D # Ts) body)"
        by(auto dest!: sees_wf_mdecl WT1_expr_locks simp add: wf_J1_mdecl_def wf_mdecl_def contains_insync_conv)
      with bisim1_call_τExec_move[OF b call, of 0 t] lenxs obtain pc' loc' stk'
        where exec: "τExec_mover_a P t body h (stk, loc, pc, None) (rev vs' @ Addr a' # stk', loc', pc', None)"
        and pc': "pc' < length (compE2 body)" and ins: "compE2 body ! pc' = Invoke M' (length vs')"
        and bisim': "P,blocks1 0 (Class D#Ts) body,h  (e, xs)  (rev vs' @ Addr a' # stk', loc', pc', None)"
        by(auto simp add: blocks1_max_vars simp del: blocks1.simps)
      let ?f = "(rev vs' @ Addr a' # stk', loc', C, M, pc')"
      from exec sees
      have exec1: "τExec_1r (compP2 P) t (None, h, (stk, loc, C, M, pc) # FRS) (None, h, ?f  # FRS)"
        by(rule τExec_mover_τExec_1r)
      with wt have "τExec_1_dr (compP2 P) t (None, h, (stk, loc, C, M, pc) # FRS) (None, h, ?f  # FRS)" using conf
        by(simp)(rule τExec_1r_τExec_1_dr)
      also with wt have conf': "compTP P  t: (None, h, ?f  # FRS) " using conf
        by simp (rule τExec_1_dr_preserves_correct_state)
      let ?f' = "([], Addr a' # vs' @ (replicate (max_vars body') undefined_value), D', M', 0)"
      from pc' ins sees sees' ha'
      have "(ε, None, h, ?f' # ?f # FRS)  exec_instr (instrs_of (compP2 P) C M ! pc') (compP2 P) t h (rev vs' @ Addr a' # stk') loc' C M pc' FRS"
        by(auto simp add: compP2_def compMb2_def nth_append split_beta)
      hence "exec_1 (compP2 P) t (None, h, ?f # FRS) ε (None, h, ?f' # ?f # FRS)"
        using exec sees by(simp add: exec_1_iff)
      with conf' have execd: "compP2 P,t  Normal (None, h, ?f # FRS) -ε-jvmd→ Normal (None, h, ?f' # ?f # FRS)"
        by(simp add: welltyped_commute[OF wt])
      hence check: "check (compP2 P) (None, h, ?f # FRS)" by(rule jvmd_NormalE)
      have "τmove2 (compP2 P) h (rev vs' @ Addr a' # stk') body pc' None" using pc' ins ha' sees'
        by(auto simp add: τmove2_iff compP2_def dest: sees_method_fun)
      with sees pc' ins have "τMove2 (compP2 P) (None, h, (rev vs' @ Addr a' # stk', loc', C, M, pc') # FRS)"
        unfolding τMove2_compP2[OF sees] by(auto simp add: compP2_def compMb2_def)
      with ‹exec_1 (compP2 P) t (None, h, ?f # FRS) ε (None, h, ?f' # ?f # FRS) check
      have "τExec_1_dt (compP2 P) t (None, h, ?f # FRS) (None, h, ?f' # ?f # FRS)" by fastforce
      also from execd sees'' sees' ins ha' pc' have "compP2 P,h  vs' [:≤] Ts'" 
        by(auto simp add: check_def compP2_def split: if_split_asm elim!: jvmd_NormalE)
      hence lenvs: "length vs' = length Ts'" by(rule list_all2_lengthD)
      from wt execd conf' have "compTP P  t:(None, h, ?f' # ?f # FRS) "
        by(rule BV_correct_d_1)
      hence "bisim1_list1 t h (blocks1 0 (Class D'#Ts') body', xs') ((e, xs) # exs) None (?f' # ?f # FRS)"
      proof
        from sees' show "P  D' sees M': Ts'T' = body' in D'" by(rule sees_method_idemp)
        show "P,blocks1 0 (Class D'#Ts') body',h  (blocks1 0 (Class D'#Ts') body', xs') 
             ([], Addr a' # vs' @ replicate (max_vars body') undefined_value, 0, None)"
          unfolding xs' by(rule bisim1_refl)
        show "max_vars (blocks1 0 (Class D' # Ts') body')  length xs'"
          unfolding xs' using lenvs by(simp add: blocks1_max_vars)
        from lenxs have "(max_vars e)  length xs" by simp
        with sees bisim' call have "bisim1_fr P h (e, xs) (rev vs' @ Addr a' # stk', loc', C, M, pc')"
          by(rule bisim1_fr.intros)
        thus "list_all2 (bisim1_fr P h) ((e, xs) # exs)
                        ((rev vs' @ Addr a' # stk', loc', C, M, pc') # FRS)"
          using bisims by simp
      qed
      moreover have "ta_bisim wbisim1 ta ε" by simp
      ultimately show ?thesis
        unfolding frs = (stk, loc, C, M, pc) # FRS xcp = None› e' exs'
        by auto(blast intro: tranclp_into_rtranclp)
    next
      case bl1_finalVal 
      with call show ?thesis by simp
    next
      case bl1_finalThrow
      with call show ?thesis by simp
    qed
  next
    case (red1Return E)
    note [simp] = exs = (E, xs') # exs' ta = ε e' = inline_call e E
    note wt = wt_compTP_compP2[OF wf]
    from bisim have bisim: "bisim1_list1 t h (e, xs) ((E, xs') # exs') xcp frs" by simp
    thus ?thesis
    proof cases
      case (bl1_Normal stk loc C M pc FRS Ts T body D)
      hence [simp]: "frs = (stk, loc, C, M, pc) # FRS"
        and conf: "compTP P  t: (xcp, h, frs) "
        and sees: "P  C sees M: TsT = body in D"
        and bisim: "P,blocks1 0 (Class D#Ts) body,h  (e, xs)  (stk, loc, pc, xcp)"
        and bisims: "list_all2 (bisim1_fr P h) ((E, xs') # exs') FRS" 
        and lenxs: "max_vars e  length xs" by auto
      from bisims obtain f FRS' where [simp]: "FRS = f # FRS'" by(fastforce simp add: list_all2_Cons1)
      from bisims have "bisim1_fr P h (E, xs') f" by simp
      then obtain C0 M0 Ts0 T0 body0 D0 stk0 loc0 pc0 a' M' vs'
        where [simp]: "f = (stk0, loc0, C0, M0, pc0)"
        and sees0: "P  C0 sees M0:Ts0T0=body0 in D0"
        and bisim0: "P,blocks1 0 (Class D0#Ts0) body0,h  (E, xs')  (stk0, loc0, pc0, None)"
        and lenxs0: "max_vars E  length xs'"
        and call0: "call1 E = (a', M', vs')"
        by cases auto
 
      let ?ee = "inline_call e E"
        
      from bisim0 call0 have pc0: "pc0 < length (compE2 (blocks1 0 (Class D0#Ts0) body0))"
        by(rule bisim1_call_pcD)
      hence pc0: "pc0 < length (compE2 body0)" by simp
      with sees_method_compP[OF sees0, where f="λC M Ts T. compMb2"]
        sees_method_compP[OF sees, where f="λC M Ts T. compMb2"] conf
      obtain ST LT where Φ: "compTP P C0 M0 ! pc0 = (ST, LT)"
        and conff: "conf_f (compP (λC M Ts T. compMb2) P) h (ST, LT) (compE2 body0 @ [Return]) (stk0, loc0, C0, M0, pc0)"
        and ins: "(compE2 body0 @ [Return]) ! pc0 = Invoke M (length Ts)"
        by(simp add: correct_state_def)(fastforce simp add: compP2_def compMb2_def dest: sees_method_fun)
      from bisim1_callD[OF bisim0 call0, of M "length Ts"] ins pc0
      have [simp]: "M' = M" by simp
        
      from ‹final e show ?thesis
      proof(cases)
        fix v
        assume [simp]: "e = Val v"
        with bisim have [simp]: "xcp = None" by(auto dest: bisim_Val_loc_eq_xcp_None)
          
        from bisim1Val2D1[OF bisim[unfolded xcp = None› e = Val v]]
        have "τExec_mover_a P t body h (stk, loc, pc, None) ([v], loc, length (compE2 body), None)"
          and [simp]: "xs = loc" by(auto simp del: blocks1.simps)
        with sees have "τExec_1r (compP2 P) t (None, h, (stk, loc, C, M, pc) # FRS) (None, h, ([v], loc, C, M, length (compE2 body)) # FRS)"
          by-(rule τExec_mover_τExec_1r)
        with conf wt have "τExec_1_dr (compP2 P) t (None, h, (stk, loc, C, M, pc) # FRS) (None, h, ([v], loc, C, M, length (compE2 body)) # FRS)"
          by(simp)(rule τExec_1r_τExec_1_dr)
        moreover with conf wt have conf': "compTP P  t:(None, h, ([v], loc, C, M, length (compE2 body)) # FRS) "
          by(simp)(rule τExec_1_dr_preserves_correct_state)
        from sees sees0
        have exec: "exec_1 (compP2 P) t (None, h, ([v], loc, C, M, length (compE2 body)) # FRS) ε (None, h, (v # drop (Suc (length Ts)) stk0, loc0, C0, M0, Suc pc0) # FRS')"
          by(simp add: exec_1_iff compP2_def compMb2_def)
        moreover with conf' wt have "compP2 P,t  Normal (None, h, ([v], loc, C, M, length (compE2 body)) # FRS) -ε-jvmd→ Normal (None, h, (v # drop (Suc (length Ts)) stk0, loc0, C0, M0, Suc pc0) # FRS')"
          by(simp add: welltyped_commute)
        hence "check (compP2 P) (None, h, ([v], loc, C, M, length (compE2 body)) # FRS)"
          by(rule jvmd_NormalE)
        moreover have "τMove2 (compP2 P) (None, h, ([v], loc, C, M, length (compE2 body)) # FRS)"
          unfolding τMove2_compP2[OF sees] by(auto)
        ultimately have "τExec_1_dt (compP2 P) t (None, h, (stk, loc, C, M, pc) # FRS) (None, h, (v # drop (Suc (length Ts)) stk0, loc0, C0, M0, Suc pc0) # FRS')"
          by -(erule rtranclp_into_tranclp1,rule τexec_1_dI)
        moreover from wt conf' exec
        have "compTP P  t:(None, h, (v # drop (Suc (length Ts)) stk0, loc0, C0, M0, Suc pc0) # FRS') "
          by(rule BV_correct_1)
        hence "bisim1_list1 t h (?ee, xs') exs' None ((v # drop (Suc (length Ts)) stk0, loc0, C0, M0, Suc pc0) # FRS')"
          using sees0
        proof
          from bisim1_inline_call_Val[OF bisim0 call0, of "length Ts" v] ins pc0
          show "P,blocks1 0 (Class D0#Ts0) body0,h  (?ee, xs')  (v # drop (Suc (length Ts)) stk0, loc0, Suc pc0, None)"
            by simp
          from lenxs0 max_vars_inline_call[of e "E"]
          show "max_vars (inline_call e E)  length xs'" by simp
          from bisims show "list_all2 (bisim1_fr P h) exs' FRS'" by simp
        qed
        ultimately show ?thesis
          by -(rule exI conjI|assumption|simp)+
      next
        fix ad
        assume [simp]: "e = Throw ad"
        
        have "stk' pc'. τExec_mover_a P t body h (stk, loc, pc, xcp) (stk', loc, pc', ad) 
                         P,blocks1 0 (Class D#Ts) body,h  (Throw ad, loc)  (stk', loc, pc', ad)"
        proof(cases xcp)
          case [simp]: None
          from bisim1_Throw_τExec_mover[OF bisim[unfolded None e = Throw ad]] obtain pc'
            where exec: "τExec_mover_a P t body h (stk, loc, pc, None) ([Addr ad], loc, pc', ad)"
            and bisim': "P,blocks1 0 (Class D#Ts) body,h  (Throw ad, xs)  ([Addr ad], loc, pc', ad)"
            and [simp]: "xs = loc" by(auto simp del: blocks1.simps)
          thus ?thesis by fastforce
        next
          case (Some a')
          with bisim have "a' = ad" "xs = loc" by(auto dest: bisim1_ThrowD)
          thus ?thesis using bisim Some by(auto)
        qed
        then obtain stk' pc' where exec: "τExec_mover_a P t body h (stk, loc, pc, xcp) (stk', loc, pc', ad)"
          and bisim': "P,blocks1 0 (Class D#Ts) body,h  (Throw ad, loc)  (stk', loc, pc', ad)" by blast
        with sees have "τExec_1r (compP2 P) t (xcp, h, (stk, loc, C, M, pc) # FRS) (ad, h, (stk', loc, C, M, pc') # FRS)"
          by-(rule τExec_mover_τExec_1r)
        with conf wt have "τExec_1_dr (compP2 P) t (xcp, h, (stk, loc, C, M, pc) # FRS) (ad, h, (stk', loc, C, M, pc') # FRS)"
          by(simp)(rule τExec_1r_τExec_1_dr)
        moreover with conf wt have conf': "compTP P  t: (ad, h, (stk', loc, C, M, pc') # FRS) "
          by(simp)(rule τExec_1_dr_preserves_correct_state)
        from bisim1_xcp_Some_not_caught[OF bisim', of "λC M Ts T. compMb2" 0 0] sees
        have match: "match_ex_table (compP2 P) (cname_of h ad) pc' (ex_table_of (compP2 P) C M) = None"
          by(simp add: compP2_def compMb2_def)
        hence exec: "exec_1 (compP2 P) t (ad, h, (stk', loc, C, M, pc') # FRS) ε (ad, h, FRS)" by(simp add: exec_1_iff)
        moreover
        with conf' wt have "compP2 P,t  Normal (ad, h, (stk', loc, C, M, pc') # FRS) -ε-jvmd→ Normal (ad, h, FRS)"
          by(simp add: welltyped_commute)
        hence "check (compP2 P) (ad, h, (stk', loc, C, M, pc') # FRS)" by(rule jvmd_NormalE)
        moreover from bisim' have "τMove2 (compP2 P) (ad, h, (stk', loc, C, M, pc') # FRS)"
          unfolding τMove2_compP2[OF sees] by(auto dest: bisim1_pc_length_compE2)
        ultimately have "τExec_1_dt (compP2 P) t (xcp, h, (stk, loc, C, M, pc) # FRS) (ad, h, FRS)"
          by -(erule rtranclp_into_tranclp1,rule τexec_1_dI)
        moreover from wt conf' exec
        have "compTP P  t: (ad, h, (stk0, loc0, C0, M0, pc0) # FRS') "
          by(simp)(rule BV_correct_1)
        hence "bisim1_list1 t h (?ee, xs') exs' ad ((stk0, loc0, C0, M0, pc0) # FRS')"
          using sees0
        proof
          from bisim1_inline_call_Throw[OF bisim0 call0] ins pc0
          show "P,blocks1 0 (Class D0#Ts0) body0,h  (?ee, xs')  (stk0, loc0, pc0, ad)" by simp
          from lenxs0 max_vars_inline_call[of e E]
          show "max_vars ?ee  length xs'" by simp
          from bisims Cons show "list_all2 (bisim1_fr P h) exs' FRS'" by simp
        qed
        moreover from call0 have "sim12_size (inline_call (Throw ad) E) > 0" by(cases E) simp_all
        ultimately show ?thesis
          by -(rule exI conjI|assumption|simp)+
      qed
    qed
  qed
qed

lemma exec_1_simulates_Red1_not_τ:
  assumes wf: "wf_J1_prog P"
  and Red1: "True,P,t ⊢1 (e, xs)/exs, h -ta (e', xs')/exs', h'"
  and bisim: "bisim1_list1 t h (e, xs) exs xcp frs"
  and τ: "¬ τMove1 P h ((e, xs), exs)"
  shows "xcp' frs'. τExec_1_dr (compP2 P) t (xcp, h, frs) (xcp', h, frs') 
           (ta' xcp'' frs''. exec_1_d (compP2 P) t (Normal (xcp', h, frs')) ta' (Normal (xcp'', h', frs'')) 
                          ¬ τMove2 (compP2 P) (xcp', h, frs')  ta_bisim wbisim1 ta ta' 
                  bisim1_list1 t h' (e',xs') exs' xcp'' frs'') 
           (call1 e = None 
            (case frs of Nil  False | (stk, loc, C, M, pc) # FRS  M' n. instrs_of (compP2 P) C M ! pc  Invoke M' n) 
            xcp'= xcp  frs' = frs)"
using Red1
proof(cases)
  case (red1Red TA)
  hence [simp]: "ta = extTA2J1 P TA" "exs' = exs"
    and red: "True,P,t ⊢1 e,(h, xs) -TA e',(h', xs')" by simp_all
  from red have hext: "hext h h'" by(auto dest: red1_hext_incr)
  from τ have τ': "¬ τmove1 P h e" by(auto intro: τmove1Block)
  note wt = wt_compTP_compP2[OF wf] 
  from bisim show ?thesis
  proof(cases)
    case (bl1_Normal stk loc C M pc FRS Ts T body D)
    hence [simp]: "frs = (stk, loc, C, M, pc) # FRS"
      and conf: "compTP P  t: (xcp, h, frs) "
      and sees: "P  C sees M: TsT = body in D"
      and bisim: "P,blocks1 0 (Class D#Ts) body,h  (e, xs)  (stk, loc, pc, xcp)"
      and bisims: "list_all2 (bisim1_fr P h) exs FRS" 
      and lenxs: "max_vars e  length xs" by auto
    from sees wf have "bsok (blocks1 0 (Class D # Ts) body) 0"
      by(auto dest!: sees_wf_mdecl WT1_expr_locks simp add: wf_J1_mdecl_def wf_mdecl_def bsok_def)

    from exec_instr_simulates_red1[OF wf bisim red this] τ'
    obtain pc' stk' loc' xcp' pc'' stk'' loc'' xcp''
      where exec1: "τExec_mover_a P t body h (stk, loc, pc, xcp) (stk', loc', pc', xcp')"
      and exec2: "exec_move_a P t body h (stk', loc', pc', xcp') (extTA2JVM (compP2 P) TA) h' (stk'', loc'', pc'', xcp'')"
      and τ2: "¬ τmove2 (compP2 P) h stk' body pc' xcp'"
      and b': "P,blocks1 0 (Class D#Ts) body, h'  (e', xs')  (stk'', loc'', pc'', xcp'')"
      and call: "call1 e = None  no_call2 (blocks1 0 (Class D # Ts) body) pc  pc' = pc  stk' = stk  loc' = loc  xcp' = xcp"
      by(fastforce simp add: exec_move_def simp del: blocks1.simps)
    from exec2 have pc'body: "pc' < length (compE2 body)" by(auto)
    from exec1 sees have exec1': "τExec_1r (compP2 P) t (xcp, h, frs) (xcp', h, (stk', loc', C, M, pc') # FRS)"
      by(auto intro: τExec_mover_τExec_1r)
    with wt have execd: "τExec_1_dr (compP2 P) t (xcp, h, frs) (xcp', h, (stk', loc', C, M, pc') # FRS)"
      using conf by(rule τExec_1r_τExec_1_dr)
    moreover { fix a
      assume [simp]: "xcp' = a"
      from exec2 sees_method_compP[OF sees, of "λC M Ts T. compMb2"] pc'body
      have "match_ex_table (compP2 P) (cname_of h a) pc' (ex_table_of (compP2 P) C M)  None"
        by(auto simp add: exec_move_def compP2_def compMb2_def elim!: exec_meth.cases) }
    note xt = this
    with τ2 sees pc'body have τ2': "¬ τMove2 (compP2 P) (xcp', h, (stk', loc', C, M, pc') # FRS)"
      unfolding τMove2_compP2[OF sees] by(auto simp add: compP2_def compMb2_def τmove2_iff)
    moreover from exec2 sees
    have exec2': "exec_1 (compP2 P) t (xcp', h, (stk', loc', C, M, pc') # FRS) (extTA2JVM (compP2 P) TA) (xcp'', h', (stk'', loc'', C, M, pc'') # FRS)"
      by(rule exec_move_exec_1)
    from wt execd conf have conf': "compTP P  t: (xcp', h, (stk', loc', C, M, pc') # FRS) "
      by(rule τExec_1_dr_preserves_correct_state)
    with exec2' wt
    have "exec_1_d (compP2 P) t (Normal (xcp', h, (stk', loc', C, M, pc') # FRS)) (extTA2JVM (compP2 P) TA) (Normal (xcp'', h', (stk'', loc'', C, M, pc'') # FRS))"
      by(simp add: welltyped_commute)
    moreover
    from τ2 sees pc'body xt have τ2': "¬ τMove2 (compP2 P) (xcp', h, (stk', loc', C, M, pc') # FRS)"
      unfolding τMove2_compP2[OF sees] by(auto simp add: compP2_def compMb2_def τmove2_iff)
    moreover from wt conf' exec2'
    have conf'': "compTP P  t: (xcp'', h', (stk'', loc'', C, M, pc'') # FRS) " by(rule BV_correct_1)
    hence "bisim1_list1 t h' (e', xs') exs xcp'' ((stk'', loc'', C, M, pc'') # FRS)" using sees b'
    proof
      from red1_preserves_len[OF red] red1_max_vars[OF red] lenxs
      show "max_vars e'  length xs'" by simp

      from bisims show "list_all2 (bisim1_fr P h') exs FRS"
        by(rule List.list_all2_mono)(rule bisim1_fr_hext_mono[OF _ hext])
    qed
    moreover from conf'' have "hconf h'" "preallocated h'" by(auto simp add: correct_state_def)
    with wf red
    have "ta_bisim wbisim1 ta (extTA2JVM (compP2 P) TA)"
      by(auto intro: ta_bisim_red_extTA2J1_extTA2JVM)
    moreover from call sees_method_compP[OF sees, of "λC M Ts T. compMb2"]
    have "call1 e = None  (case frs of []  False | (stk, loc, C, M, pc) # FRS  M' n. instrs_of (compP2 P) C M ! pc  Invoke M' n)  xcp' = xcp  (stk', loc', C, M, pc') # FRS = frs"
      by(auto simp add: no_call2_def compP2_def compMb2_def)
    ultimately show ?thesis by -(rule exI conjI|assumption|simp)+
  next
    case bl1_finalVal
    with red show ?thesis by auto
  next
    case bl1_finalThrow
    with red show ?thesis by(auto elim: red1_cases)
  qed
next
  case red1Call
  with τ have False
    by(auto simp add: synthesized_call_def dest!: τmove1_not_call1[where P=P and h=h] dest: sees_method_fun)
  thus ?thesis ..
next
  case red1Return
  with τ have False by auto
  thus ?thesis ..
qed

end

end

Theory JVMJ1

(*  Title:      JinjaThreads/Compiler/JVMJ1.thy
    Author:     Andreas Lochbihler
*)

section ‹Correctness of Stage 2: From JVM to intermediate language›

theory JVMJ1 imports
  J1JVMBisim
begin

declare split_paired_Ex[simp del]

lemma rec_option_is_case_option: "rec_option = case_option"
apply (rule ext)+
apply (rename_tac y)
apply (case_tac y)
apply auto
done

context J1_JVM_heap_base begin

lemma assumes ha: "typeof_addr h a = Class_type D"
  and subclsObj: "P  D * Throwable"
  shows bisim1_xcp_τRed:
  " P,e,h  (e', xs)  (stk, loc, pc, a);
    match_ex_table (compP f P) (cname_of h a) pc (compxE2 e 0 0) = None;
    n. n + max_vars e'  length xs e n 
   τred1r P t h (e', xs) (Throw a, loc)  P,e,h  (Throw a, loc)  (stk, loc, pc, a)"

  and bisims1_xcp_τReds:
  " P,es,h  (es', xs) [↔] (stk, loc, pc, a);
     match_ex_table (compP f P) (cname_of h a) pc (compxEs2 es 0 0) = None;
     n. n + max_varss es'  length xs  ℬs es n 
   vs es''. τreds1r P t h (es', xs) (map Val vs @ Throw a # es'', loc) 
               P,es,h  (map Val vs @ Throw a # es'', loc) [↔] (stk, loc, pc, a)"
proof(induct "(e', xs)" "(stk, loc, pc, a :: 'addr)"
    and "(es', xs)" "(stk, loc, pc, a :: 'addr)"
    arbitrary: e' xs stk loc pc and es' xs stk loc pc rule: bisim1_bisims1.inducts)
  case bisim1NewThrow thus ?case
    by(fastforce intro: bisim1_bisims1.intros)
next
  case bisim1NewArray thus ?case
    by(auto intro: rtranclp.rtrancl_into_rtrancl New1ArrayThrow bisim1_bisims1.intros dest: bisim1_ThrowD elim!: NewArray_τred1r_xt)
next
  case bisim1NewArrayThrow thus ?case
    by(fastforce intro: bisim1_bisims1.intros)
next
  case bisim1NewArrayFail thus ?case
    by(fastforce intro: bisim1_bisims1.intros)
next
  case bisim1Cast thus ?case
    by(fastforce intro: rtranclp.rtrancl_into_rtrancl Cast1Throw bisim1_bisims1.intros dest: bisim1_ThrowD elim!: Cast_τred1r_xt)
next
  case bisim1CastThrow thus ?case
    by(fastforce intro: bisim1_bisims1.intros)
next
  case bisim1CastFail thus ?case
    by(fastforce intro: bisim1_bisims1.intros)
next
  case bisim1InstanceOf thus ?case
    by(fastforce intro: rtranclp.rtrancl_into_rtrancl InstanceOf1Throw bisim1_bisims1.intros dest: bisim1_ThrowD elim!: InstanceOf_τred1r_xt)
next
  case bisim1InstanceOfThrow thus ?case
    by(fastforce intro: bisim1_bisims1.intros)
next
  case bisim1BinOp1 thus ?case
    by(fastforce intro: rtranclp.rtrancl_into_rtrancl Bin1OpThrow1 bisim1_bisims1.intros simp add: match_ex_table_append dest: bisim1_ThrowD elim!: BinOp_τred1r_xt1)
next
  case bisim1BinOp2 thus ?case
    by(clarsimp simp add: match_ex_table_append_not_pcs compxE2_size_convs compxE2_stack_xlift_convs match_ex_table_shift_pc_None)
      (fastforce intro: rtranclp.rtrancl_into_rtrancl red1_reds1.intros bisim1BinOpThrow2 elim!: BinOp_τred1r_xt2)
next
  case bisim1BinOpThrow1 thus ?case
    by(auto simp add: match_ex_table_append intro: bisim1_bisims1.intros)
next
  case (bisim1BinOpThrow2 e xs stk loc pc e1 bop)
  note bisim = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  hence "xs = loc" by(auto dest: bisim1_ThrowD)
  with bisim show ?case
    by(auto intro: bisim1_bisims1.bisim1BinOpThrow2)
next
  case bisim1BinOpThrow thus ?case
    by(fastforce intro: bisim1_bisims1.intros)
next
  case bisim1LAss1 thus ?case
    by(fastforce intro: rtranclp.rtrancl_into_rtrancl LAss1Throw bisim1_bisims1.intros dest: bisim1_ThrowD elim!: LAss_τred1r)
next
  case bisim1LAssThrow thus ?case
    by(fastforce intro: bisim1_bisims1.intros)
next
  case bisim1AAcc1 thus ?case
    by(fastforce intro: rtranclp.rtrancl_into_rtrancl AAcc1Throw1 bisim1_bisims1.intros simp add: match_ex_table_append dest: bisim1_ThrowD elim!: AAcc_τred1r_xt1)
next
  case bisim1AAcc2 thus ?case
    by(clarsimp simp add: match_ex_table_append_not_pcs compxE2_size_convs compxE2_stack_xlift_convs match_ex_table_shift_pc_None)
      (fastforce intro: rtranclp.rtrancl_into_rtrancl red1_reds1.intros bisim1AAccThrow2 elim!: AAcc_τred1r_xt2)
next
  case bisim1AAccThrow1 thus ?case
    by(auto simp add: match_ex_table_append intro: bisim1_bisims1.intros)
next
  case bisim1AAccThrow2 thus ?case
    by(auto simp add: match_ex_table_append intro: bisim1_bisims1.intros dest: bisim1_ThrowD)
next
  case bisim1AAccFail thus ?case
    by(fastforce intro: bisim1_bisims1.intros)
next
  case bisim1AAss1 thus ?case
    by(fastforce intro: rtranclp.rtrancl_into_rtrancl AAss1Throw1 bisim1_bisims1.intros simp add: match_ex_table_append dest: bisim1_ThrowD elim!: AAss_τred1r_xt1)
next
  case bisim1AAss2 thus ?case
    by(clarsimp simp add: compxE2_size_convs compxE2_stack_xlift_convs)
      (fastforce simp add: match_ex_table_append intro: rtranclp.rtrancl_into_rtrancl red1_reds1.intros bisim1AAssThrow2 elim!: AAss_τred1r_xt2)
next
  case bisim1AAss3 thus ?case
    by(clarsimp simp add: compxE2_size_convs compxE2_stack_xlift_convs)
      (fastforce simp add: match_ex_table_append intro: rtranclp.rtrancl_into_rtrancl red1_reds1.intros bisim1AAssThrow3 elim!: AAss_τred1r_xt3)
next
  case bisim1AAssThrow1 thus ?case
    by(auto simp add: match_ex_table_append intro: bisim1_bisims1.intros)
next
  case (bisim1AAssThrow2 e xs stk loc pc i e2)
  note bisim = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  hence "xs = loc" by(auto dest: bisim1_ThrowD)
  with bisim show ?case
    by(auto intro: bisim1_bisims1.bisim1AAssThrow2)
next
  case (bisim1AAssThrow3 e xs stk loc pc A i)
  note bisim = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  hence "xs = loc" by(auto dest: bisim1_ThrowD)
  with bisim show ?case
    by(auto intro: bisim1_bisims1.bisim1AAssThrow3)
next
  case bisim1AAssFail thus ?case
    by(fastforce intro: bisim1_bisims1.intros)
next
  case bisim1ALength thus ?case
    by(fastforce intro: rtranclp.rtrancl_into_rtrancl ALength1Throw bisim1_bisims1.intros dest: bisim1_ThrowD elim!: ALength_τred1r_xt)
next
  case bisim1ALengthThrow thus ?case
    by(fastforce intro: bisim1_bisims1.intros)
next
  case bisim1ALengthNull thus ?case
    by(fastforce intro: bisim1_bisims1.intros)
next
  case bisim1FAcc thus ?case
    by(fastforce intro: rtranclp.rtrancl_into_rtrancl FAcc1Throw bisim1_bisims1.intros dest: bisim1_ThrowD elim!: FAcc_τred1r_xt)
next
  case bisim1FAccThrow thus ?case
    by(fastforce intro: bisim1_bisims1.intros)
next
  case bisim1FAccNull thus ?case
    by(fastforce intro: bisim1_bisims1.intros)
next
  case bisim1FAss1 thus ?case
    by(fastforce intro: rtranclp.rtrancl_into_rtrancl FAss1Throw1 bisim1_bisims1.intros simp add: match_ex_table_append dest: bisim1_ThrowD elim!: FAss_τred1r_xt1)
next
  case bisim1FAss2 thus ?case
    by(clarsimp simp add: match_ex_table_append_not_pcs compxE2_size_convs compxE2_stack_xlift_convs)
      (fastforce intro: rtranclp.rtrancl_into_rtrancl red1_reds1.intros bisim1FAssThrow2 elim!: FAss_τred1r_xt2)
next
  case bisim1FAssThrow1 thus ?case
    by(auto simp add: match_ex_table_append intro: bisim1_bisims1.intros)
next
  case (bisim1FAssThrow2 e2 xs stk loc pc e)
  note bisim = P,e2,h  (Throw a, xs)  (stk, loc, pc, a)
  hence "xs = loc" by(auto dest: bisim1_ThrowD)
  with bisim show ?case
    by(auto intro: bisim1_bisims1.bisim1FAssThrow2)
next
  case bisim1FAssNull thus ?case
    by(fastforce intro: bisim1_bisims1.intros)
next
  case bisim1CAS1 thus ?case
    by(fastforce intro: rtranclp.rtrancl_into_rtrancl CAS1Throw bisim1_bisims1.intros simp add: match_ex_table_append dest: bisim1_ThrowD elim!: CAS_τred1r_xt1)
next
  case bisim1CAS2 thus ?case
    by(clarsimp simp add: compxE2_size_convs compxE2_stack_xlift_convs)
      (fastforce simp add: match_ex_table_append intro: rtranclp.rtrancl_into_rtrancl red1_reds1.intros bisim1CASThrow2 elim!: CAS_τred1r_xt2)
next
  case bisim1CAS3 thus ?case
    by(clarsimp simp add: compxE2_size_convs compxE2_stack_xlift_convs)
      (fastforce simp add: match_ex_table_append intro: rtranclp.rtrancl_into_rtrancl red1_reds1.intros bisim1CASThrow3 elim!: CAS_τred1r_xt3)
next
  case bisim1CASThrow1 thus ?case
    by(auto simp add: match_ex_table_append intro: bisim1_bisims1.intros)
next
  case (bisim1CASThrow2 e xs stk loc pc i e2)
  note bisim = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  hence "xs = loc" by(auto dest: bisim1_ThrowD)
  with bisim show ?case
    by(auto intro: bisim1_bisims1.bisim1CASThrow2)
next
  case (bisim1CASThrow3 e xs stk loc pc A i)
  note bisim = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  hence "xs = loc" by(auto dest: bisim1_ThrowD)
  with bisim show ?case
    by(auto intro: bisim1_bisims1.bisim1CASThrow3)
next
  case bisim1CASFail thus ?case
    by(fastforce intro: bisim1_bisims1.intros)
next
  case bisim1Call1 thus ?case
    by(fastforce intro: rtranclp.rtrancl_into_rtrancl Call1ThrowObj bisim1_bisims1.intros simp add: match_ex_table_append dest: bisim1_ThrowD elim!: Call_τred1r_obj)
next
  case bisim1CallParams thus ?case
    by(clarsimp simp add: match_ex_table_append_not_pcs compxE2_size_convs compxEs2_size_convs compxE2_stack_xlift_convs compxEs2_stack_xlift_convs match_ex_table_shift_pc_None)
      (fastforce intro: rtranclp.rtrancl_into_rtrancl Call1ThrowParams[OF refl] bisim1CallThrowParams elim!: Call_τred1r_param)
next
  case bisim1CallThrowObj thus ?case
    by(auto simp add: match_ex_table_append intro: bisim1_bisims1.intros)
next
  case (bisim1CallThrowParams es vs es' xs stk loc pc obj M)
  note bisim = P,es,h  (map Val vs @ Throw a # es', xs) [↔] (stk, loc, pc, a)
  hence "xs = loc" by(auto dest: bisims1_ThrowD)
  with bisim show ?case
    by(auto intro: bisim1_bisims1.bisim1CallThrowParams)
next
  case bisim1CallThrow thus ?case
    by(auto intro: bisim1_bisims1.intros)
next
  case (bisim1BlockSome4 e e' xs stk loc pc V Ty v)
  from n. n + max_vars {V:Ty=None; e'}  length xs {V:Ty=v; e} n
  have V: "V < length xs" by simp
  from bisim1BlockSome4 have Red: "τred1r P t h (e', xs) (Throw a, loc)"
    and bisim: "P,e,h  (Throw a, loc)  (stk, loc, pc, a)"
    by(auto simp add: match_ex_table_append_not_pcs compxE2_size_convs compxEs2_size_convs compxE2_stack_xlift_convs compxEs2_stack_xlift_convs match_ex_table_shift_pc_None intro!: exI[where x="Suc V"] elim: meta_impE)
  note len = τred1r_preserves_len[OF Red]
  from Red have "τred1r P t h ({V:Ty=None; e'}, xs) ({V:Ty=None; Throw a}, loc)" by(auto intro: Block_None_τred1r_xt)
  thus ?case using V len bisim 
    by(auto intro: τmove1BlockThrow Block1Throw bisim1BlockThrowSome elim!: rtranclp.rtrancl_into_rtrancl)
next
  case bisim1BlockThrowSome thus ?case
    by(auto dest: bisim1_ThrowD intro: bisim1_bisims1.bisim1BlockThrowSome)
next
  case (bisim1BlockNone e e' xs stk loc pc V Ty)
  hence Red: "τred1r P t h (e', xs) (Throw a, loc)"
    and bisim: "P,e,h  (Throw a, loc)  (stk, loc, pc, a)"
    by(auto elim: meta_impE intro!: exI[where x="Suc V"])
  from Red have len: "length loc = length xs" by(rule τred1r_preserves_len)
  from n. n + max_vars {V:Ty=None; e'}  length xs {V:Ty=None; e} n
  have V: "V < length xs" by simp
  from Red have "τred1r P t h ({V:Ty=None; e'}, xs) ({V:Ty=None; Throw a}, loc)" by(rule Block_None_τred1r_xt)
  thus ?case using V len bisim
    by(auto intro: τmove1BlockThrow Block1Throw bisim1BlockThrowNone elim!: rtranclp.rtrancl_into_rtrancl)
next
  case bisim1BlockThrowNone thus ?case
    by(auto dest: bisim1_ThrowD intro: bisim1_bisims1.bisim1BlockThrowNone)
next
  case bisim1Sync1 thus ?case
    by(fastforce intro: rtranclp.rtrancl_into_rtrancl Synchronized1Throw1 bisim1_bisims1.intros simp add: match_ex_table_append dest: bisim1_ThrowD elim!: Sync_τred1r_xt)
next
  case (bisim1Sync4 e2 e' xs stk loc pc V e1 a')
  from P,e2,h  (e', xs)  (stk, loc, pc, a)
  have "pc < length (compE2 e2)" by(auto dest!: bisim1_xcp_pcD)
  with ‹match_ex_table (compP f P) (cname_of h a) (Suc (Suc (Suc (length (compE2 e1) + pc)))) (compxE2 (syncV (e1) e2) 0 0) = None› subclsObj ha
  have False by(simp add: match_ex_table_append matches_ex_entry_def split: if_split_asm)
  thus ?case ..
next
  case bisim1Sync10 thus ?case 
    by(fastforce intro: bisim1_bisims1.intros)
next
  case bisim1Sync11 thus ?case
    by(fastforce intro: bisim1_bisims1.intros)
next
  case bisim1Sync12 thus ?case
    by(fastforce intro: bisim1_bisims1.intros)
next
  case bisim1Sync14 thus ?case
    by(fastforce intro: bisim1_bisims1.intros)
next
  case bisim1SyncThrow thus ?case
    by(auto simp add: match_ex_table_append intro: bisim1_bisims1.intros)
next
  case bisim1Seq1 thus ?case
    by(fastforce intro: rtranclp.rtrancl_into_rtrancl Seq1Throw bisim1_bisims1.intros dest: bisim1_ThrowD elim!: Seq_τred1r_xt simp add: match_ex_table_append)
next
  case bisim1SeqThrow1 thus ?case
    by(auto simp add: match_ex_table_append intro: bisim1_bisims1.intros)
next
  case bisim1Seq2 thus ?case
    by(auto simp add: match_ex_table_append_not_pcs compxE2_size_convs compxE2_stack_xlift_convs match_ex_table_shift_pc_None intro: bisim1_bisims1.bisim1Seq2)
next
  case bisim1Cond1 thus ?case
    by(fastforce intro: rtranclp.rtrancl_into_rtrancl Cond1Throw bisim1_bisims1.intros dest: bisim1_ThrowD elim!: Cond_τred1r_xt simp add: match_ex_table_append)
next
  case bisim1CondThen thus ?case
    by(clarsimp simp add: match_ex_table_append)
     (auto simp add: match_ex_table_append_not_pcs compxE2_size_convs compxE2_stack_xlift_convs match_ex_table_shift_pc_None intro: bisim1_bisims1.bisim1CondThen)
next
  case bisim1CondElse thus ?case
    by(clarsimp simp add: match_ex_table_append)
      (auto simp add: match_ex_table_append_not_pcs compxE2_size_convs compxE2_stack_xlift_convs match_ex_table_shift_pc_None intro: bisim1_bisims1.bisim1CondElse)
next
  case bisim1CondThrow thus ?case
    by(auto simp add: match_ex_table_append intro: bisim1_bisims1.intros)
next
  case bisim1While3 thus ?case
    by(fastforce intro: rtranclp.rtrancl_into_rtrancl Cond1Throw bisim1_bisims1.intros dest: bisim1_ThrowD elim!: Cond_τred1r_xt simp add: match_ex_table_append)
next
  case (bisim1While4 e e' xs stk loc pc c)
  hence "τred1r P t h (e', xs) (Throw a, loc)  P,e,h  (Throw a, loc)  (stk, loc, pc, a)"
    by(auto simp add: match_ex_table_append_not_pcs compxE2_size_convs compxEs2_size_convs compxE2_stack_xlift_convs compxEs2_stack_xlift_convs match_ex_table_shift_pc_None)
  hence "τred1r P t h (e';;while (c) e, xs) (Throw a, loc)"
    "P,while (c) e,h  (Throw a, loc)  (stk, loc, Suc (length (compE2 c) + pc), a)"
    by(auto intro: rtranclp.rtrancl_into_rtrancl Seq1Throw τmove1SeqThrow bisim1WhileThrow2 elim!: Seq_τred1r_xt)
  thus ?case ..
next
  case bisim1WhileThrow1 thus ?case
    by(auto simp add: match_ex_table_append intro: bisim1_bisims1.intros)
next
  case bisim1WhileThrow2 thus ?case
    by(auto simp add: match_ex_table_append intro: bisim1_bisims1.intros dest: bisim1_ThrowD)
next
  case bisim1Throw1 thus ?case
    by(fastforce intro: rtranclp.rtrancl_into_rtrancl Throw1Throw bisim1_bisims1.intros dest: bisim1_ThrowD elim!: Throw_τred1r_xt)
next
  case bisim1Throw2 thus ?case
    by(fastforce intro: bisim1_bisims1.intros)
next
  case bisim1ThrowNull thus ?case
    by(fastforce intro: bisim1_bisims1.intros)
next
  case bisim1ThrowThrow thus ?case
    by(fastforce intro: bisim1_bisims1.intros)
next
  case (bisim1Try e e' xs stk loc pc C V e2)
  hence red: "τred1r P t h (e', xs) (Throw a, loc)"
    and bisim: "P,e,h  (Throw a, loc)  (stk, loc, pc, a)"
    by(auto simp add: match_ex_table_append)
  from red have Red: "τred1r P t h (try e' catch(C V) e2, xs) (try Throw a catch(C V) e2, loc)" by(rule Try_τred1r_xt)
  from ‹match_ex_table (compP f P) (cname_of h a) pc (compxE2 (try e catch(C V) e2) 0 0) = None›
  have "¬ matches_ex_entry (compP f P) (cname_of h a) pc (0, length (compE2 e), C, Suc (length (compE2 e)), 0)"
    by(auto simp add: match_ex_table_append split: if_split_asm)
  moreover from P,e,h  (e', xs)  (stk, loc, pc, a)
  have "pc < length (compE2 e)" by(auto dest: bisim1_xcp_pcD)
  ultimately have subcls: "¬ P  D * C" using ha by(simp add: matches_ex_entry_def cname_of_def)
  with ha have "True,P,t ⊢1 try Throw a catch(C V) e2, (h, loc) -ε Throw a, (h, loc)"
    by -(rule Red1TryFail, auto)
  moreover from bisim ha subcls
  have "P,try e catch(C V) e2,h  (Throw a, loc)  (stk, loc, pc, a)"
    by(rule bisim1TryFail)
  ultimately show ?case using Red by(blast intro: rtranclp.rtrancl_into_rtrancl τmove1TryThrow)
next
  case (bisim1TryCatch2 e2 e' xs stk loc pc e1 C V)
  hence *: "τred1r P t h (e', xs) (Throw a, loc)  P,e2,h  (Throw a, loc)  (stk, loc, pc, a)"
    by(clarsimp simp add: match_ex_table_append matches_ex_entry_def split: if_split_asm)
      (auto simp add: match_ex_table_append compxE2_size_convs compxE2_stack_xlift_convs match_ex_table_shift_pc_None elim: meta_impE intro!: exI[where x="Suc V"])
  moreover note τred1r_preserves_len[OF *[THEN conjunct1]]
  moreover from n. n + max_vars {V:Class C=None; e'}  length xs (try e1 catch(C V) e2) n
  have "V < length xs" by simp
  ultimately show ?case 
    by(fastforce intro: rtranclp.rtrancl_into_rtrancl Block1Throw τmove1BlockThrow bisim1TryCatchThrow elim!: Block_None_τred1r_xt)
next
  case (bisim1TryFail e xs stk loc pc C'' C' V e2)
  note bisim = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  hence "xs = loc" by(auto dest: bisim1_ThrowD)
  with bisim typeof_addr h a = Class_type C'' ¬ P  C'' * C'
  show ?case by(auto intro: bisim1_bisims1.bisim1TryFail)
next
  case (bisim1TryCatchThrow e2 xs stk loc pc e C' V)
  from P,e2,h  (Throw a, xs)  (stk, loc, pc, a) have "xs = loc"
    by(auto dest: bisim1_ThrowD)
  with P,e2,h  (Throw a, xs)  (stk, loc, pc, a) show ?case
    by(auto intro: bisim1_bisims1.bisim1TryCatchThrow)
next
  case (bisims1List1 e e' xs stk loc pc es)
  hence "τred1r P t h (e', xs) (Throw a, loc)"
    and bisim: "P,e,h  (Throw a, loc)  (stk, loc, pc, a)" by(auto simp add: match_ex_table_append)
  hence "τreds1r P t h (e' # es, xs) (map Val [] @ Throw a # es, loc)" by(auto intro: τred1r_inj_τreds1r)
  moreover from bisim
  have "P,e#es,h  (Throw a # es, loc) [↔] (stk, loc, pc, a)"
    by(rule bisim1_bisims1.bisims1List1)
  ultimately show ?case by fastforce
next
  case (bisims1List2 es es' xs stk loc pc e v)
  hence "vs es''. τreds1r P t h (es', xs) (map Val vs @ Throw a # es'', loc)  P,es,h  (map Val vs @ Throw a # es'', loc) [↔] (stk, loc, pc, a)"
    by(auto simp add: match_ex_table_append_not_pcs compxEs2_size_convs compxEs2_stack_xlift_convs match_ex_table_shift_pc_None)
  then obtain vs es'' where red: "τreds1r P t h (es', xs) (map Val vs @ Throw a # es'', loc)" 
    and bisim: "P,es,h  (map Val vs @ Throw a # es'', loc) [↔] (stk, loc, pc, a)" by blast
  from red have "τreds1r P t h (Val v # es', xs) (map Val (v # vs) @ Throw a # es'', loc)"
    by(auto intro: τreds1r_cons_τreds1r)
  moreover from bisim 
  have "P,e # es,h  (map Val (v # vs) @ Throw a # es'', loc) [↔] (stk @ [v], loc, length (compE2 e) + pc, a)"
    by(auto intro: bisim1_bisims1.bisims1List2)
  ultimately show ?case by fastforce
qed

primrec conf_xcp' :: "'m prog  'heap  'addr option  bool" where
  "conf_xcp' P h None = True"
| "conf_xcp' P h a = (D. typeof_addr h a = Class_type D  P  D * Throwable)"

lemma conf_xcp_conf_xcp':
  "conf_xcp P h xcp i  conf_xcp' P h xcp"
by(cases xcp) auto

lemma conf_xcp'_compP [simp]: "conf_xcp' (compP f P) = conf_xcp' P"
by(clarsimp simp add: fun_eq_iff conf_xcp'_def rec_option_is_case_option)

end

context J1_heap_base begin

lemmas τred1_Val_simps [simp] =
  τred1r_Val τred1t_Val τreds1r_map_Val τreds1t_map_Val

end

context J1_JVM_conf_read begin

lemma assumes wf: "wf_J1_prog P"
  and hconf: "hconf h" "preallocated h"
  and tconf: "P,h  t √t"
  shows red1_simulates_exec_instr:
  " P, E, h  (e, xs)  (stk, loc, pc, xcp);
     exec_move_d P t E h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp');
     n + max_vars e  length xs; bsok E n; P,h  stk [:≤] ST; conf_xcp' (compP2 P) h xcp 
   e'' xs''. P, E, h'  (e'', xs'')  (stk', loc', pc', xcp') 
     (if τmove2 (compP2 P) h stk E pc xcp
      then h' = h  (if xcp' = None  pc < pc' then τred1r else τred1t) P t h (e, xs) (e'', xs'')
      else ta' e' xs'. τred1r P t h (e, xs) (e', xs')  True,P,t ⊢1 e', (h, xs') -ta' e'', (h', xs'')  ta_bisim wbisim1 (extTA2J1 P ta') ta  ¬ τmove1 P h e'  (call1 e = None  no_call2 E pc  e' = e  xs' = xs))"
  (is " _; ?exec E stk loc pc xcp stk' loc' pc' xcp'; _; _; _; _ 
        e'' xs''. P, E, h'  (e'', xs'')  (stk', loc', pc', xcp')  ?red e xs e'' xs'' E stk pc pc' xcp xcp'")

  and reds1_simulates_exec_instr:
  " P, Es, h  (es, xs) [↔] (stk, loc, pc, xcp);
     exec_moves_d P t Es h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp');
     n + max_varss es  length xs; bsoks Es n; P,h  stk [:≤] ST; conf_xcp' (compP2 P) h xcp 
   es'' xs''. P, Es, h'  (es'', xs'') [↔] (stk', loc', pc', xcp') 
     (if τmoves2 (compP2 P) h stk Es pc xcp
      then h' = h  (if xcp' = None  pc < pc' then τreds1r else τreds1t) P t h (es, xs) (es'', xs'')
      else ta' es' xs'. τreds1r P t h (es, xs) (es', xs')  True,P,t ⊢1 es', (h, xs') [-ta'→] es'', (h', xs'')  ta_bisim wbisim1 (extTA2J1 P ta') ta  ¬ τmoves1 P h es'  (calls1 es = None  no_calls2 Es pc  es' = es  xs' = xs))"
  (is " _; ?execs Es stk loc pc xcp stk' loc' pc' xcp'; _; _; _; _ 
        es'' xs''. P, Es, h'  (es'', xs'') [↔] (stk', loc', pc', xcp')  ?reds es xs es'' xs'' Es stk pc pc' xcp xcp'")
proof(induction E n e xs stk loc pc xcp and Es n es xs stk loc pc xcp
    arbitrary: stk' loc' pc' xcp' ST and stk' loc' pc' xcp' ST rule: bisim1_bisims1_inducts_split)
  case (bisim1Val2 e n v xs)
  from ?exec e [v] xs (length (compE2 e)) None stk' loc' pc' xcp'
  have False by(auto dest: exec_meth_length_compE2D simp add: exec_move_def)
  thus ?case ..
next
  case (bisim1New C' n xs)
  note exec = ‹exec_move_d P t (new C') h ([], xs, 0, None) ta h' (stk', loc', pc', xcp')
  have τ: "¬ τmove2 (compP2 P) h [] (new C') 0 None" "¬ τmove1 P h (new C')" by(auto simp add: τmove2_iff)
  show ?case
  proof(cases "allocate h (Class_type C') = {}")
    case True
    have "P,new C',h'  (THROW OutOfMemory, xs)  ([], xs, 0, addr_of_sys_xcpt OutOfMemory)"
      by(rule bisim1NewThrow)
    with exec τ True show ?thesis
      by(fastforce intro: Red1NewFail elim!: exec_meth.cases simp add: exec_move_def)
  next
    case False
    have "a h'. P,new C',h'  (addr a, xs)  ([Addr a], xs, length (compE2 (new C')), None)"
      by(rule bisim1Val2) auto
    thus ?thesis using exec False τ
      apply(simp add: exec_move_def)
      apply(erule exec_meth.cases)
      apply simp_all
      apply clarsimp
      apply(auto intro!: Red1New exI simp add: ta_bisim_def)
      done
  qed
next
  case (bisim1NewThrow C' n xs)
  from ?exec (new C') [] xs 0 addr_of_sys_xcpt OutOfMemory stk' loc' pc' xcp'
  have False by(auto elim: exec_meth.cases simp add: exec_move_def)
  thus ?case ..
next
  case (bisim1NewArray e n e' xs stk loc pc xcp U)
  note IH = bisim1NewArray.IH(2)
  note exec = ?exec (newA Ue) stk loc pc xcp stk' loc' pc' xcp'
  note bisim = P,e,h  (e', xs)  (stk, loc, pc, xcp)
  note len = n + max_vars (newA Ue')  length xs
  note bsok = ‹bsok (newA Ue) n
  from bisim have pc: "pc  length (compE2 e)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e)")
    case True
    with exec have exec': "?exec e stk loc pc xcp stk' loc' pc' xcp'"
      by(auto simp add: exec_move_newArray)
    from True have "τmove2 (compP2 P) h stk (newA Ue) pc xcp = τmove2 (compP2 P) h stk e pc xcp" by(simp add: τmove2_iff)
    moreover have "no_call2 e pc  no_call2 (newA Ue) pc" by(simp add: no_call2_def)
    ultimately show ?thesis using IH[OF exec' _ _ P,h  stk [:≤] ST ‹conf_xcp' (compP2 P) h xcp] len bsok
      by(fastforce intro: bisim1_bisims1.bisim1NewArray New1ArrayRed elim!: NewArray_τred1r_xt NewArray_τred1t_xt)
  next
    case False
    with pc have [simp]: "pc = length (compE2 e)" by simp
    with bisim obtain v where stk: "stk = [v]" and xcp: "xcp = None"
      by(auto dest: bisim1_pc_length_compE2D)
    with bisim pc len bsok have red: "τred1r P t h (e', xs) (Val v, loc)"
      by(auto intro: bisim1_Val_τred1r simp add: bsok_def)
    hence "τred1r P t h (newA Ue', xs) (newA UVal v, loc)" by(rule NewArray_τred1r_xt)
    moreover have τ: "¬ τmove2 (compP2 P) h [v] (newA Ue) pc None" by(simp add: τmove2_iff)
    moreover have "¬ τmove1 P h (newA UVal v)" by auto
    moreover from exec stk xcp obtain I
      where [simp]: "v = Intg I" by(auto elim!: exec_meth.cases simp add: exec_move_def)
    have "ta' e''. P,newA Ue,h'  (e'',loc)  (stk', loc', pc', xcp')  True,P,t ⊢1 newA UVal v,(h, loc) -ta' e'',(h', loc)  ta_bisim wbisim1 (extTA2J1 P ta') ta"
    proof(cases "I <s 0")
      case True with exec stk xcp show ?thesis
        by(fastforce elim!: exec_meth.cases intro: bisim1NewArrayFail Red1NewArrayNegative simp add: exec_move_def)
    next
      case False
      show ?thesis
      proof(cases "allocate h (Array_type U (nat (sint I))) = {}")
        case True
        with False exec stk xcp show ?thesis
          by(fastforce elim!: exec_meth.cases intro: bisim1NewArrayFail Red1NewArrayFail simp add: exec_move_def)
      next
        case False
        have "a h'. P,newA Ue,h'  (addr a, loc)  ([Addr a], loc, length (compE2 (newA Ue)), None)"
          by(rule bisim1Val2) simp
        with False ¬ I <s 0 exec stk xcp show ?thesis
          apply(simp add: exec_move_def)
          apply(erule exec_meth.cases)
          apply simp_all
          apply clarsimp
          apply(auto intro!: Red1NewArray exI simp add: ta_bisim_def)
          done
      qed
    qed
    moreover have "no_call2 (newA Ue) pc" by(simp add: no_call2_def)
    ultimately show ?thesis using exec stk xcp by fastforce
  qed
next
  case (bisim1NewArrayThrow e n a xs stk loc pc U)
  note exec = ?exec (newA Ue) stk loc pc a stk' loc' pc' xcp'
  note bisim = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  from bisim have pc: "pc < length (compE2 e)" by(auto dest: bisim1_ThrowD)
  from bisim have "match_ex_table (compP2 P) (cname_of h a) (0 + pc) (compxE2 e 0 0) = None"
    unfolding compP2_def by(rule bisim1_xcp_Some_not_caught)
  with exec pc have False by (auto elim!: exec_meth.cases simp add: exec_move_def)
  thus ?case ..
next
  case (bisim1NewArrayFail e n U a xs v)
  note exec = ?exec (newA Ue) [v] xs (length (compE2 e)) a stk' loc' pc' xcp'
  hence False by(auto elim!: exec_meth.cases dest: match_ex_table_pc_length_compE2 simp add: exec_move_def)
  thus ?case ..
next
  case (bisim1Cast e n e' xs stk loc pc xcp U)
  note IH = bisim1Cast.IH(2)
  note exec = ?exec (Cast U e) stk loc pc xcp stk' loc' pc' xcp'
  note bisim = P,e,h  (e', xs)  (stk, loc, pc, xcp)
  note len = n + max_vars (Cast U e')  length xs
  note ST = P,h  stk [:≤] ST
  note bsok = ‹bsok (Cast U e) n
  from bisim have pc: "pc  length (compE2 e)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e)")
    case True
    with exec have exec': "?exec e stk loc pc xcp stk' loc' pc' xcp'" by(auto simp add: exec_move_Cast)
    from True have "τmove2 (compP2 P) h stk (Cast U e) pc xcp = τmove2 (compP2 P) h stk e pc xcp" by(simp add: τmove2_iff)
    moreover have "no_call2 e pc  no_call2 (Cast U e) pc" by(simp add: no_call2_def)
    ultimately show ?thesis using IH[OF exec' _ _ ST ‹conf_xcp' (compP2 P) h xcp] len bsok
      by(fastforce intro: bisim1_bisims1.bisim1Cast Cast1Red elim!: Cast_τred1r_xt Cast_τred1t_xt)
  next
    case False
    with pc have [simp]: "pc = length (compE2 e)" by simp
    with bisim obtain v where stk: "stk = [v]" and xcp: "xcp = None"
      by(auto dest: bisim1_pc_length_compE2D)
    with bisim pc len bsok have red: "τred1r P t h (e', xs) (Val v, loc)"
      by(auto intro: bisim1_Val_τred1r simp add: bsok_def)
    hence "τred1r P t h (Cast U e', xs) (Cast U (Val v), loc)" by(rule Cast_τred1r_xt)
    also from exec have [simp]: "h' = h" "ta = ε" by(auto simp add: exec_move_def elim!: exec_meth.cases split: if_split_asm)
    have "e''. P,Cast U e,h  (e'',loc)  (stk', loc', pc', xcp')  True,P,t ⊢1 Cast U (Val v),(h, loc) -ε e'',(h, loc)"
    proof(cases "P  the (typeofh v)  U")
      case False with exec stk xcp bsok ST show ?thesis
        by(fastforce simp add: compP2_def exec_move_def exec_meth_instr list_all2_Cons1 conf_def intro: bisim1CastFail Red1CastFail)
    next
      case True
      have "P,Cast U e,h  (Val v, loc)  ([v], loc, length (compE2 (Cast U e)), None)"
          by(rule bisim1Val2) simp
      with exec stk xcp ST True show ?thesis
        by(fastforce simp add: compP2_def exec_move_def exec_meth_instr list_all2_Cons1 conf_def intro: Red1Cast)
    qed
    then obtain e'' where bisim': "P,Cast U e,h  (e'',loc)  (stk', loc', pc', xcp')"
      and red: "True,P,t ⊢1 Cast U (Val v),(h, loc) -ε e'',(h, loc)" by blast
    have "τmove1 P h (Cast U (Val v))" by(rule τmove1CastRed)
    with red have "τred1t P t h (Cast U (Val v), loc) (e'', loc)" by(auto intro: τred1t_1step)
    also have τ: "τmove2 (compP2 P) h [v] (Cast U e) pc None" by(simp add: τmove2_iff)
    moreover have "no_call2 (Cast U e) pc" by(simp add: no_call2_def)
    ultimately show ?thesis using exec stk xcp bisim' by fastforce
  qed
next
  case (bisim1CastThrow e n a xs stk loc pc U)
  note exec = ?exec (Cast U e) stk loc pc a stk' loc' pc' xcp'
  note bisim = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  from bisim have pc: "pc < length (compE2 e)" by(auto dest: bisim1_ThrowD)
  from bisim have "match_ex_table (compP2 P) (cname_of h a) (0 + pc) (compxE2 e 0 0) = None"
    unfolding compP2_def by(rule bisim1_xcp_Some_not_caught)
  with exec pc have False by (auto elim!: exec_meth.cases simp add: exec_move_def)
  thus ?case ..
next
  case (bisim1CastFail e n U xs v)
  note exec = ?exec (Cast U e) [v] xs (length (compE2 e)) addr_of_sys_xcpt ClassCast stk' loc' pc' xcp'
  hence False by(auto elim!: exec_meth.cases dest: match_ex_table_pc_length_compE2 simp add: exec_move_def)
  thus ?case ..
next
  case (bisim1InstanceOf e n e' xs stk loc pc xcp U)
  note IH = bisim1InstanceOf.IH(2)
  note exec = ?exec (e instanceof U) stk loc pc xcp stk' loc' pc' xcp'
  note bisim = P,e,h  (e', xs)  (stk, loc, pc, xcp)
  note len = n + max_vars (e' instanceof U)  length xs
  note ST = P,h  stk [:≤] ST
  note bsok = ‹bsok (e instanceof U) n
  from bisim have pc: "pc  length (compE2 e)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e)")
    case True
    with exec have exec': "?exec e stk loc pc xcp stk' loc' pc' xcp'" by(auto simp add: exec_move_InstanceOf)
    from True have "τmove2 (compP2 P) h stk (e instanceof U) pc xcp = τmove2 (compP2 P) h stk e pc xcp"
      by(simp add: τmove2_iff)
    moreover have "no_call2 e pc  no_call2 (e instanceof U) pc" by(simp add: no_call2_def)
    ultimately show ?thesis using IH[OF exec' _ _ ST ‹conf_xcp' (compP2 P) h xcp] len bsok
      by(fastforce intro: bisim1_bisims1.bisim1InstanceOf InstanceOf1Red elim!: InstanceOf_τred1r_xt InstanceOf_τred1t_xt)
  next
    case False
    with pc have [simp]: "pc = length (compE2 e)" by simp
    with bisim obtain v where stk: "stk = [v]" and xcp: "xcp = None"
      by(auto dest: bisim1_pc_length_compE2D)
    with bisim pc len bsok have red: "τred1r P t h (e', xs) (Val v, loc)"
      by(auto intro: bisim1_Val_τred1r simp add: bsok_def)
    hence "τred1r P t h (e' instanceof U, xs) ((Val v) instanceof U, loc)" by(rule InstanceOf_τred1r_xt)
    also let ?v = "Bool (v  Null  P  the (typeofh v)  U)"
    from exec ST stk xcp have [simp]: "h' = h" "ta = ε" "xcp' = None" "loc' = loc" "stk' = [?v]" "pc' = Suc pc"
      by(auto simp add: exec_move_def list_all2_Cons1 conf_def compP2_def elim!: exec_meth.cases split: if_split_asm)
    have bisim': "P,e instanceof U,h  (Val ?v, loc)  ([?v], loc, length (compE2 (e instanceof U)), None)"
      by(rule bisim1Val2) simp
    from exec stk xcp ST
    have red: "True,P,t ⊢1 (Val v) instanceof U,(h, loc) -ε Val ?v ,(h, loc)"
      by(auto simp add: compP2_def exec_move_def exec_meth_instr list_all2_Cons1 conf_def intro: Red1InstanceOf)
    have "τmove1 P h ((Val v) instanceof U)" by(rule τmove1InstanceOfRed)
    with red have "τred1t P t h ((Val v) instanceof U, loc) (Val ?v, loc)" by(auto intro: τred1t_1step)
    also have τ: "τmove2 (compP2 P) h [v] (e instanceof U) pc None" by(simp add: τmove2_iff)
    moreover have "no_call2 (e instanceof U) pc" by(simp add: no_call2_def)
    ultimately show ?thesis using exec stk xcp bisim' by(fastforce)
  qed
next
  case (bisim1InstanceOfThrow e n a xs stk loc pc U)
  note exec = ?exec (e instanceof U) stk loc pc a stk' loc' pc' xcp'
  note bisim = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  from bisim have pc: "pc < length (compE2 e)" by(auto dest: bisim1_ThrowD)
  from bisim have "match_ex_table (compP2 P) (cname_of h a) (0 + pc) (compxE2 e 0 0) = None"
    unfolding compP2_def by(rule bisim1_xcp_Some_not_caught)
  with exec pc have False by (auto elim!: exec_meth.cases simp add: exec_move_def)
  thus ?case ..
next
  case (bisim1Val v n xs)
  from ?exec (Val v) [] xs 0 None stk' loc' pc' xcp'
  have "stk' = [v]" "loc' = xs" "h' = h" "pc' = length (compE2 (Val v))" "xcp' = None"
    by(auto elim: exec_meth.cases simp add: exec_move_def)
  moreover have "P,Val v,h  (Val v, xs)  ([v], xs, length (compE2 (Val v)), None)"
    by(rule bisim1Val2) simp
  moreover have "τmove2 (compP2 P) h [] (Val v) 0 None" by(rule τmove2Val)
  ultimately show ?case by(auto)
next
  case (bisim1Var V n xs)
  note exec = ?exec (Var V) [] xs 0 None stk' loc' pc' xcp'
  moreover note len = n + max_vars (Var V)  length xs
  moreover have "τmove2 (compP2 P) h [] (Var V) 0 None" "τmove1 P h (Var V)"
    by(auto intro: τmove1Var simp add: τmove2_iff)
  moreover have "P,Var V,h  (Val (xs ! V), xs)  ([xs ! V], xs, length (compE2 (Var V)), None)"
    by(rule bisim1Val2) simp
  ultimately show ?case by(fastforce elim!: exec_meth.cases intro: Red1Var r_into_rtranclp simp add: exec_move_def)
next
  case (bisim1BinOp1 e1 n e1' xs stk loc pc xcp e2 bop)
  note IH1 = bisim1BinOp1.IH(2)
  note IH2 = bisim1BinOp1.IH(4)
  note exec = ?exec (e1 «bop» e2) stk loc pc xcp stk' loc' pc' xcp'
  note bisim1 = P,e1,h  (e1', xs)  (stk, loc, pc, xcp)
  note bisim2 = P,e2,h  (e2, loc)  ([], loc, 0, None)
  note len = n + max_vars (e1' «bop» e2)  length xs
  note ST = P,h  stk [:≤] ST
  note bsok = ‹bsok (e1 «bop» e2) n
  from bisim1 have pc: "pc  length (compE2 e1)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e1)")
    case True
    with exec have exec': "?exec e1 stk loc pc xcp stk' loc' pc' xcp'" by(auto simp add: exec_move_BinOp1)
    from True have τ: "τmove2 (compP2 P) h stk (e1 «bop» e2) pc xcp = τmove2 (compP2 P) h stk e1 pc xcp"
      by(simp add: τmove2_iff)
    with IH1[OF exec' _ _ ST ‹conf_xcp' (compP2 P) h xcp] bisim2 len bsok obtain e'' xs''
      where bisim': "P,e1,h'  (e'', xs'')  (stk', loc', pc', xcp')"
      and red: "?red e1' xs e'' xs'' e1 stk pc pc' xcp xcp'" by auto
    from bisim' have "P,e1 «bop» e2,h'  (e'' «bop» e2, xs'')  (stk', loc', pc', xcp')"
      by(rule bisim1_bisims1.bisim1BinOp1)
    moreover from True have "no_call2 (e1 «bop» e2) pc = no_call2 e1 pc" by(simp add: no_call2_def)
    ultimately show ?thesis using red τ
      by(fastforce intro: Bin1OpRed1 elim!: BinOp_τred1r_xt1 BinOp_τred1t_xt1)
  next
    case False
    with pc have pc: "pc = length (compE2 e1)" by auto
    with bisim1 obtain v where e1': "is_val e1'  e1' = Val v" 
      and stk: "stk = [v]" and xcp: "xcp = None" and call: "call1 e1' = None"
      by(auto dest: bisim1_pc_length_compE2D)
    with bisim1 pc len bsok have rede1': "τred1r P t h (e1', xs) (Val v, loc)"
      by(auto intro: bisim1_Val_τred1r simp add: bsok_def)
    hence rede1'': "τred1r P t h (e1' «bop» e2, xs) (Val v «bop» e2, loc)" by(rule BinOp_τred1r_xt1)
    moreover from pc exec stk xcp
    have "exec_meth_d (compP2 P) (compE2 (e1 «bop» e2)) (compxE2 (e1 «bop» e2) 0 0) t h ([] @ [v], loc, length (compE2 e1) + 0, None) ta h' (stk', loc', pc', xcp')"
      by(simp add: compxE2_size_convs compxE2_stack_xlift_convs exec_move_def)
    hence exec': "exec_meth_d (compP2 P) (compE2 e2) (stack_xlift (length [v]) (compxE2 e2 0 0)) t h ([] @ [v], loc, 0, None) ta h' (stk', loc', pc' - length (compE2 e1), xcp')"
      and pc': "pc'  length (compE2 e1)" by(safe dest!: BinOp_exec2D)simp_all
    then obtain PC' where PC': "pc' = length (compE2 e1) + PC'"
      by -(rule that[where PC'35="pc' - length (compE2 e1)"], simp)
    from exec' bisim2 obtain stk'' where stk': "stk' = stk'' @ [v]"
      and exec'': "exec_move_d P t e2 h ([], loc, 0, None) ta h' (stk'', loc', pc' - length (compE2 e1), xcp')"
      by(unfold exec_move_def)(drule (1) exec_meth_stk_split, auto)
    with pc xcp have τ: "τmove2 (compP2 P) h [v] (e1 «bop» e2) (length (compE2 e1)) None = τmove2 (compP2 P) h [] e2 0 None"
      using τinstr_stk_drop_exec_move[where stk="[]" and vs = "[v]"]
      by(simp add: τmove2_iff τinstr_stk_drop_exec_move)
    from bisim1 have "length xs = length loc" by(rule bisim1_length_xs)
    with IH2[OF exec'', of "[]"] len bsok obtain e'' xs''
      where bisim': "P,e2,h'  (e'', xs'')  (stk'', loc', pc' - length (compE2 e1), xcp')"
      and red: "?red e2 loc e'' xs'' e2 [] 0 (pc' - length (compE2 e1)) None xcp'" by auto
    from bisim'
    have "P,e1 «bop» e2,h'  (Val v «bop» e'', xs'')  (stk'' @ [v], loc', length (compE2 e1) + (pc' - length (compE2 e1)), xcp')"
      by(rule bisim1_bisims1.bisim1BinOp2)
    moreover from red τ 
    have "?red (Val v «bop» e2) loc (Val v «bop» e'') xs'' (e1 «bop» e2) [v] (length (compE2 e1)) pc' None xcp'"
      by(fastforce intro: Bin1OpRed2 elim!: BinOp_τred1r_xt2 BinOp_τred1t_xt2 simp add: no_call2_def)
    moreover have "no_call2 (e1 «bop» e2) (length (compE2 e1))" by(simp add: no_call2_def)
    ultimately show ?thesis using τ stk' pc xcp pc' PC' bisim1 bisim2 e1' stk call by(fastforce elim!: rtranclp_trans)
  qed
next
  case (bisim1BinOp2 e2 n e2' xs stk loc pc xcp e1 bop v1)
  note IH2 = bisim1BinOp2.IH(2)
  note exec = ?exec (e1 «bop» e2) (stk @ [v1]) loc (length (compE2 e1) + pc) xcp stk' loc' pc' xcp'
  note bisim1 = P,e1,h  (e1, xs)  ([], xs, 0, None)
  note bisim2 = P,e2,h  (e2', xs)  (stk, loc, pc, xcp)
  note len = n + max_vars (Val v1 «bop» e2')  length xs
  note bsok = ‹bsok (e1 «bop» e2) n
  note ST = P,h  stk @ [v1] [:≤] ST
  then obtain ST2 T where "ST = ST2 @ [T]" "P,h  stk [:≤] ST2" "P,h  v1 :≤ T"
    by(auto simp add: list_all2_append1 length_Suc_conv)
  from bisim2 have pc: "pc  length (compE2 e2)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e2)")
    case True
    with exec have exec': "exec_meth_d (compP2 P) (compE2 e2) (stack_xlift (length [v1]) (compxE2 e2 0 0)) t h (stk @ [v1], loc, pc, xcp) ta h' (stk', loc', pc' - length (compE2 e1), xcp')"
      and pc': "pc'  length (compE2 e1)"
      by(unfold exec_move_def)(safe dest!: BinOp_exec2D)
    from exec' bisim2 obtain stk'' where stk': "stk' = stk'' @ [v1]"
      and exec'': "exec_move_d P t e2 h (stk, loc, pc, xcp) ta h' (stk'', loc', pc' - length (compE2 e1), xcp')"
      by -(drule (1) exec_meth_stk_split, auto simp add: exec_move_def)
    with True have τ: "τmove2 (compP2 P) h (stk @ [v1]) (e1 «bop» e2) (length (compE2 e1) + pc) xcp = τmove2 (compP2 P) h stk e2 pc xcp"
      by(auto simp add: τmove2_iff τinstr_stk_drop_exec_move)
    from IH2[OF exec'' _ _ P,h  stk [:≤] ST2 ‹conf_xcp' (compP2 P) h xcp] len bsok obtain e'' xs''
      where bisim': "P,e2,h'  (e'', xs'')  (stk'', loc', pc' - length (compE2 e1), xcp')"
      and red: "?red e2' xs e'' xs'' e2 stk pc (pc' - length (compE2 e1)) xcp xcp'" by auto
    from bisim' have "P,e1 «bop» e2,h'  (Val v1 «bop» e'', xs'')  (stk'' @ [v1], loc', length (compE2 e1) + (pc' - length (compE2 e1)), xcp')"
      by(rule bisim1_bisims1.bisim1BinOp2)
    with red τ stk' pc' True show ?thesis
      by(fastforce intro: Bin1OpRed2 elim!: BinOp_τred1r_xt2 BinOp_τred1t_xt2 split: if_split_asm simp add: no_call2_def)
  next
    case False
    with pc have [simp]: "pc = length (compE2 e2)" by simp
    with bisim2 obtain v2 where e2': "is_val e2'  e2' = Val v2" 
      and stk: "stk = [v2]" and xcp: "xcp = None" and call: "call1 e2' = None"
      by(auto dest: bisim1_pc_length_compE2D)
    with bisim2 pc len bsok have red: "τred1r P t h (e2', xs) (Val v2, loc)"
      by(auto intro: bisim1_Val_τred1r simp add: bsok_def)
    hence red1: "τred1r P t h (Val v1 «bop» e2', xs) (Val v1 «bop» Val v2, loc)" by(rule BinOp_τred1r_xt2)
    show ?thesis
    proof(cases "the (binop bop v1 v2)")
      case (Inl v)
      note red1
      also from exec xcp ST stk Inl
      have "τred1r P t h (Val v1 «bop» Val v2, loc) (Val v, loc)"
        by(force simp add: exec_move_def exec_meth_instr list_all2_Cons1 conf_def compP2_def dest: binop_progress intro: r_into_rtranclp Red1BinOp τmove1BinOp)
      also have τ: "τmove2 (compP2 P) h [v2, v1] (e1 «bop» e2) (length (compE2 e1) + length (compE2 e2)) None"
        by(simp add: τmove2_iff)
      moreover have "P,e1 «bop» e2,h  (Val v, loc)  ([v], loc, length (compE2 (e1 «bop» e2)), None)"
        by(rule bisim1Val2) simp
      ultimately show ?thesis using exec xcp stk call Inl by(auto simp add: exec_move_def exec_meth_instr)
    next
      case (Inr a)
      note red1
      also from exec xcp ST stk Inr
      have "τred1r P t h (Val v1 «bop» Val v2, loc) (Throw a, loc)"
        by(force simp add: exec_move_def exec_meth_instr list_all2_Cons1 conf_def compP2_def dest: binop_progress intro: r_into_rtranclp Red1BinOpFail τmove1BinOp)
      also have τ: "τmove2 (compP2 P) h [v2, v1] (e1 «bop» e2) (length (compE2 e1) + length (compE2 e2)) None"
        by(simp add: τmove2_iff)
      moreover
      have "P,e1 «bop» e2,h  (Throw a, loc)  ([v2, v1], loc, length (compE2 e1) + length (compE2 e2), a)"
        by(rule bisim1BinOpThrow)
      ultimately show ?thesis using exec xcp stk call Inr by(auto simp add: exec_move_def exec_meth_instr)
    qed
  qed
next
  case (bisim1BinOpThrow1 e1 n a xs stk loc pc e2 bop)
  note exec = ?exec (e1 «bop» e2) stk loc pc a stk' loc' pc' xcp'
  note bisim1 = P,e1,h  (Throw a, xs)  (stk, loc, pc, a)
  from bisim1 have pc: "pc < length (compE2 e1)" by(auto dest: bisim1_ThrowD)
  from bisim1 have "match_ex_table (compP2 P) (cname_of h a) (0 + pc) (compxE2 e1 0 0) = None"
    unfolding compP2_def by(rule  bisim1_xcp_Some_not_caught)
  with exec pc have False by(auto elim!: exec_meth.cases simp add: match_ex_table_not_pcs_None exec_move_def)
  thus ?case ..
next
  case (bisim1BinOpThrow2 e2 n a xs stk loc pc e1 bop v1)
  note exec = ?exec (e1 «bop» e2) (stk @ [v1]) loc (length (compE2 e1) + pc) a stk' loc' pc' xcp'
  note bisim2 = P,e2,h  (Throw a, xs)  (stk, loc, pc, a)
  hence "match_ex_table (compP2 P) (cname_of h a) (length (compE2 e1) + pc) (compxE2 e2 (length (compE2 e1)) 0) = None"
    unfolding compP2_def by(rule bisim1_xcp_Some_not_caught)
  with exec have False
    apply(auto elim!: exec_meth.cases simp add: match_ex_table_append_not_pcs exec_move_def)
    apply(auto simp only: compxE2_size_convs compxE2_stack_xlift_convs match_ex_table_stack_xlift_eq_Some_conv)
    done
  thus ?case ..
next 
  case (bisim1BinOpThrow e1 n e2 bop a xs v1 v2)
  note ?exec (e1 «bop» e2) [v1, v2] xs (length (compE2 e1) + length (compE2 e2)) a stk' loc' pc' xcp'
  hence False
    by(auto elim!: exec_meth.cases simp add: match_ex_table_append_not_pcs compxE2_size_convs exec_move_def
               dest!: match_ex_table_shift_pcD match_ex_table_pc_length_compE2)
  thus ?case ..
next
  case (bisim1LAss1 e n e' xs stk loc pc xcp V)
  note IH = bisim1LAss1.IH(2)
  note exec = ?exec (V := e) stk loc pc xcp stk' loc' pc' xcp'
  note bisim = P,e,h  (e', xs)  (stk, loc, pc, xcp)
  note len = n + max_vars (V := e')  length xs
  note bsok = ‹bsok (V:=e) n
  from bisim have pc: "pc  length (compE2 e)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e)")
    case True
    with exec have exec': "?exec e stk loc pc xcp stk' loc' pc' xcp'" by(auto simp add: exec_move_LAss)
    from True have "τmove2 (compP2 P) h stk (V := e) pc xcp = τmove2 (compP2 P) h stk e pc xcp" by(simp add: τmove2_iff)
    with IH[OF exec' _ _ P,h  stk [:≤] ST ‹conf_xcp' (compP2 P) h xcp] len bsok show ?thesis
      by(fastforce intro: bisim1_bisims1.bisim1LAss1 LAss1Red elim!: LAss_τred1r LAss_τred1t simp add: no_call2_def)
  next
    case False
    with pc have [simp]: "pc = length (compE2 e)" by simp
    with bisim obtain v where stk: "stk = [v]" and xcp: "xcp = None"
      by(auto dest: bisim1_pc_length_compE2D)
    with bisim pc len bsok have red: "τred1r P t h (e', xs) (Val v, loc)"
      by(auto intro: bisim1_Val_τred1r simp add: bsok_def)
    hence "τred1r P t h (V := e', xs) (V := Val v, loc)" by(rule LAss_τred1r)
    also have "τmove1 P h (V := Val v)" by(rule τmove1LAssRed)
    with exec stk xcp have "τred1r P t h (V := Val v, loc) (unit, loc[V := v])"
      by(auto intro!: r_into_rtranclp Red1LAss simp add: exec_move_def elim!: exec_meth.cases)
    also have τ: "τmove2 (compP2 P) h [v] (V := e) pc None" by(simp add: τmove2_iff)
    moreover have "P,(V := e),h  (unit, loc[V := v])  ([], loc[V := v], Suc (length (compE2 e)), None)"
      by(rule bisim1LAss2)
    ultimately show ?thesis using exec stk xcp
      by(fastforce elim!: exec_meth.cases simp add: exec_move_def)
  qed
next
  case (bisim1LAss2 e n V xs)
  note bisim = P,e,h  (e, xs)  ([], xs, 0, None)
  note exec = ?exec (V := e) [] xs (Suc (length (compE2 e))) None stk' loc' pc' xcp'
  hence "stk' = [Unit]" "loc' = xs" "pc' = length (compE2 (V := e))" "xcp' = None" "h' = h"
    by(auto elim!: exec_meth.cases simp add: exec_move_def)
  moreover have "τmove2 (compP2 P) h [] (V := e) (Suc (length (compE2 e))) None" by(simp add: τmove2_iff)
  moreover have "P,V:=e,h'  (unit, xs)  ([Unit], xs, length (compE2 (V := e)), None)"
    by(rule bisim1Val2) simp
  ultimately show ?case by(auto)
next
  case (bisim1LAssThrow e n a xs stk loc pc V)
  note exec = ?exec (V := e) stk loc pc a stk' loc' pc' xcp'
  note bisim = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  from bisim have pc: "pc < length (compE2 e)" by(auto dest: bisim1_ThrowD)
  from bisim have "match_ex_table (compP2 P) (cname_of h a) (0 + pc) (compxE2 e 0 0) = None"
    unfolding compP2_def by(rule  bisim1_xcp_Some_not_caught)
  with exec pc have False by (auto elim!: exec_meth.cases simp add: exec_move_def)
  thus ?case ..
next
  case (bisim1AAcc1 a n a' xs stk loc pc xcp i)
  note IH1 = bisim1AAcc1.IH(2)
  note IH2 = bisim1AAcc1.IH(4)
  note exec = ?exec (ai) stk loc pc xcp stk' loc' pc' xcp'
  note bisim1 = P,a,h  (a', xs)  (stk, loc, pc, xcp)
  note bisim2 = P,i,h  (i, loc)  ([], loc, 0, None)
  note len = n + max_vars (a'i)  length xs
  note bsok = ‹bsok (ai) n
  from bisim1 have pc: "pc  length (compE2 a)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 a)")
    case True
    with exec have exec': "?exec a stk loc pc xcp stk' loc' pc' xcp'" by(auto simp add: exec_move_AAcc1)
    from True have τ: "τmove2 (compP2 P) h stk (ai) pc xcp = τmove2 (compP2 P) h stk a pc xcp" by(auto intro: τmove2AAcc1)
    with IH1[OF exec' _ _ P,h  stk [:≤] ST ‹conf_xcp' (compP2 P) h xcp] len bsok obtain e'' xs''
      where bisim': "P,a,h'  (e'', xs'')  (stk', loc', pc', xcp')"
      and red: "?red a' xs e'' xs'' a stk pc pc' xcp xcp'" by auto
    from bisim' have "P,ai,h'  (e''i, xs'')  (stk', loc', pc', xcp')" by(rule bisim1_bisims1.bisim1AAcc1)
    moreover from True have "no_call2 (ai) pc = no_call2 a pc" by(simp add: no_call2_def)
    ultimately show ?thesis using red τ by(fastforce intro: AAcc1Red1 elim!: AAcc_τred1r_xt1 AAcc_τred1t_xt1)
  next
    case False
    with pc have pc: "pc = length (compE2 a)" by auto
    with bisim1 obtain v where a': "is_val a'  a' = Val v" 
      and stk: "stk = [v]" and xcp: "xcp = None" and call: "call1 a' = None"
      by(auto dest: bisim1_pc_length_compE2D)
    with bisim1 pc len bsok have rede1': "τred1r P t h (a', xs) (Val v, loc)"
      by(auto intro: bisim1_Val_τred1r simp add: bsok_def)
    hence "τred1r P t h (a'i, xs) (Val vi, loc)" by(rule AAcc_τred1r_xt1)
    moreover from pc exec stk xcp
    have exec': "exec_meth_d (compP2 P) (compE2 a @ compE2 i @ [ALoad]) (compxE2 a 0 0 @ shift (length (compE2 a)) (stack_xlift (length [v]) (compxE2 i 0 0))) t h ([] @ [v], loc, length (compE2 a) + 0, None) ta h' (stk', loc', pc', xcp')"
      by(simp add: compxE2_size_convs compxE2_stack_xlift_convs exec_move_def)
    hence "exec_meth_d (compP2 P) (compE2 i @ [ALoad]) (stack_xlift (length [v]) (compxE2 i 0 0)) t h ([] @ [v], loc, 0, None) ta h' (stk', loc', pc' - length (compE2 a), xcp')"
      by(rule exec_meth_drop_xt) auto
    hence "exec_meth_d (compP2 P) (compE2 i) (stack_xlift (length [v]) (compxE2 i 0 0)) t h ([] @ [v], loc, 0, None) ta h' (stk', loc', pc' - length (compE2 a), xcp')"
      by(rule exec_meth_take) simp
    with bisim2 obtain stk'' where stk': "stk' = stk'' @ [v]"
      and exec'': "exec_move_d P t i h ([], loc, 0, None) ta h' (stk'', loc', pc' - length (compE2 a), xcp')"
      unfolding exec_move_def by(blast dest: exec_meth_stk_split)
    with pc xcp have τ: "τmove2 (compP2 P) h ([] @ [v]) (ai) (length (compE2 a)) None = τmove2 (compP2 P) h [] i 0 None"
      using τinstr_stk_drop_exec_move[where stk="[]" and vs="[v]"]
      by(auto simp add: τmove2_iff τinstr_stk_drop_exec_move)
    from bisim1 have "length xs = length loc" by(rule bisim1_length_xs)
    with IH2[OF exec''] len bsok obtain e'' xs''
      where bisim': "P,i,h'  (e'', xs'')  (stk'', loc', pc' - length (compE2 a), xcp')"
      and red: "?red i loc e'' xs'' i [] 0 (pc' - length (compE2 a)) None xcp'" by(fastforce)
    from bisim'
    have "P,ai,h'  (Val ve'', xs'')  (stk'' @ [v], loc', length (compE2 a) + (pc' - length (compE2 a)), xcp')"
      by(rule bisim1_bisims1.bisim1AAcc2)
    moreover from red τ have "?red (Val vi) loc (Val ve'') xs'' (ai) [v] (length (compE2 a)) pc' None xcp'"
      by(fastforce intro: AAcc1Red2 elim!: AAcc_τred1r_xt2 AAcc_τred1t_xt2 split: if_split_asm simp add: no_call2_def)
    moreover from exec' have "pc'  length (compE2 a)"
      by(rule exec_meth_drop_xt_pc) auto
    moreover have "no_call2 (ai) pc" using pc by(simp add: no_call2_def)
    ultimately show ?thesis using τ stk' pc xcp stk call
      by(fastforce elim!: rtranclp_trans)+
  qed
next
  case (bisim1AAcc2 i n i' xs stk loc pc xcp a v)
  note IH2 = bisim1AAcc2.IH(2)
  note exec = ?exec (ai) (stk @ [v]) loc (length (compE2 a) + pc) xcp stk' loc' pc' xcp'
  note bisim2 = P,i,h  (i', xs)  (stk, loc, pc, xcp)
  note len = n + max_vars (Val vi')  length xs
  note bsok = ‹bsok (ai) n
  from bisim2 have pc: "pc  length (compE2 i)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 i)")
    case True
    from exec have exec': "exec_meth_d (compP2 P) (compE2 a @ compE2 i @ [ALoad]) (compxE2 a 0 0 @ shift (length (compE2 a)) (stack_xlift (length [v]) (compxE2 i 0 0))) t h (stk @ [v], loc, length (compE2 a) + pc, xcp) ta h' (stk', loc', pc', xcp')"
      by(simp add: shift_compxE2 stack_xlift_compxE2 exec_move_def)
    hence "exec_meth_d (compP2 P) (compE2 i @ [ALoad]) (stack_xlift (length [v]) (compxE2 i 0 0)) t h (stk @ [v], loc, pc, xcp) ta h' (stk', loc', pc' - length (compE2 a), xcp')"
      by(rule exec_meth_drop_xt) auto
    hence "exec_meth_d (compP2 P) (compE2 i) (stack_xlift (length [v]) (compxE2 i 0 0)) t h (stk @ [v], loc, pc, xcp) ta h' (stk', loc', pc' - length (compE2 a), xcp')"
      using True by(rule exec_meth_take)
    with bisim2 obtain stk'' where stk': "stk' = stk'' @ [v]"
      and exec'': "exec_move_d P t i h (stk, loc, pc, xcp) ta h' (stk'', loc', pc' - length (compE2 a), xcp')"
      unfolding exec_move_def by(blast dest: exec_meth_stk_split)
    with True have τ: "τmove2 (compP2 P) h (stk @ [v]) (ai) (length (compE2 a) + pc) xcp = τmove2 (compP2 P) h stk i pc xcp"
      by(auto simp add: τmove2_iff τinstr_stk_drop_exec_move)
    moreover from P,h  stk @ [v] [:≤] ST obtain ST2
      where "P,h  stk [:≤] ST2" by(auto simp add: list_all2_append1)
    from IH2[OF exec'' _ _ this ‹conf_xcp' (compP2 P) h xcp] len bsok obtain e'' xs''
      where bisim': "P,i,h'  (e'', xs'')  (stk'', loc', pc' - length (compE2 a), xcp')"
      and red: "?red i' xs e'' xs'' i stk pc (pc' - length (compE2 a)) xcp xcp'" by auto
    from bisim' have "P,ai,h'  (Val ve'', xs'')  (stk'' @ [v], loc', length (compE2 a) + (pc' - length (compE2 a)), xcp')"
      by(rule bisim1_bisims1.bisim1AAcc2)
    moreover from exec' have "pc'  length (compE2 a)"
      by(rule exec_meth_drop_xt_pc) auto
    moreover have "no_call2 i pc  no_call2 (ai) (length (compE2 a) + pc)"
      by(simp add: no_call2_def)
    ultimately show ?thesis using red τ stk' True
      by(fastforce intro: AAcc1Red2 elim!: AAcc_τred1r_xt2 AAcc_τred1t_xt2 split: if_split_asm)
  next
    case False
    with pc have [simp]: "pc = length (compE2 i)" by simp
    with bisim2 obtain v2 where i': "is_val i'  i' = Val v2" 
      and stk: "stk = [v2]" and xcp: "xcp = None" and call: "call1 i' = None"
      by(auto dest: bisim1_pc_length_compE2D)
    with bisim2 pc len bsok have red: "τred1r P t h (i', xs) (Val v2, loc)"
      by(auto intro: bisim1_Val_τred1r simp add: bsok_def)
    hence "τred1r P t h (Val vi', xs) (Val vVal v2, loc)" by(rule AAcc_τred1r_xt2)
    moreover have τ: "¬ τmove2 (compP2 P) h [v2, v] (ai) (length (compE2 a) + length (compE2 i)) None"
      by(simp add: τmove2_iff)
    moreover 
    have "ta' e''. P,ai,h'  (e'',loc)  (stk', loc', pc', xcp')  True,P,t ⊢1 Val vVal v2, (h, loc) -ta' e'',(h', loc)  ta_bisim wbisim1 (extTA2J1 P ta') ta"
    proof(cases "v = Null")
      case True with exec stk xcp show ?thesis
        by(fastforce elim!: exec_meth.cases simp add: exec_move_def intro: bisim1AAccFail Red1AAccNull)
    next
      case False
      with exec xcp stk obtain U el A len I where [simp]: "v = Addr A" and hA: "typeof_addr h A = Array_type U len"
        and [simp]: "v2 = Intg I" by(auto simp add: exec_move_def exec_meth_instr is_Ref_def conf_def split: if_split_asm)
      show ?thesis
      proof(cases "0 <=s I  sint I < int len")
        case True
        hence "¬ I <s 0" by auto
        moreover
        with exec xcp stk True hA obtain v3 where "stk' = [v3]" "heap_read h A (ACell (nat (sint I))) v3"
          by(auto simp add: exec_move_def exec_meth_instr is_Ref_def)
        moreover        
        have "P,ai,h'  (Val v3,loc)  ([v3], loc, length (compE2 (ai)), None)"
          by(rule bisim1Val2) simp
        ultimately show ?thesis using exec stk xcp True hA
          by(fastforce elim!: exec_meth.cases intro: Red1AAcc simp add: exec_move_def ta_upd_simps ta_bisim_def split: if_split_asm)
      next
        case False
        with exec stk xcp hA show ?thesis
          by(fastforce elim!: exec_meth.cases simp add: is_Ref_def exec_move_def intro: bisim1AAccFail Red1AAccBounds split: if_split_asm)
      qed
    qed
    ultimately show ?thesis using exec xcp stk call by fastforce
  qed
next
  case (bisim1AAccThrow1 A n a xs stk loc pc i)
  note exec = ?exec (Ai) stk loc pc a stk' loc' pc' xcp'
  note bisim1 = P,A,h  (Throw a, xs)  (stk, loc, pc, a)
  from bisim1 have pc: "pc < length (compE2 A)" by(auto dest: bisim1_ThrowD)
  from bisim1 have "match_ex_table (compP2 P) (cname_of h a) (0 + pc) (compxE2 A 0 0) = None"
    unfolding compP2_def by(rule bisim1_xcp_Some_not_caught)
  with exec pc have False
    by(auto elim!: exec_meth.cases simp add: match_ex_table_not_pcs_None exec_move_def)
  thus ?case ..
next
  case (bisim1AAccThrow2 i n a xs stk loc pc A v)
  note exec = ?exec (Ai) (stk @ [v]) loc (length (compE2 A) + pc) a stk' loc' pc' xcp'
  note bisim2 = P,i,h  (Throw a, xs)  (stk, loc, pc, a)
  hence "match_ex_table (compP2 P) (cname_of h a) (length (compE2 A) + pc) (compxE2 i (length (compE2 A)) 0) = None"
    unfolding compP2_def by(rule bisim1_xcp_Some_not_caught)
  with exec have False
    apply(auto elim!: exec_meth.cases simp add: match_ex_table_append_not_pcs exec_move_def)
    apply(auto simp only: compxE2_size_convs compxE2_stack_xlift_convs match_ex_table_stack_xlift_eq_Some_conv)
    done
  thus ?case ..
next
  case (bisim1AAccFail a n i ad xs v v')
  note ?exec (ai) [v, v'] xs (length (compE2 a) + length (compE2 i)) ad stk' loc' pc' xcp'
  hence False
    by(auto elim!: exec_meth.cases simp add: match_ex_table_append_not_pcs compxE2_size_convs exec_move_def
               dest!: match_ex_table_shift_pcD match_ex_table_pc_length_compE2)
  thus ?case ..
next
  case (bisim1AAss1 a n a' xs stk loc pc xcp i e)
  note IH1 = bisim1AAss1.IH(2)
  note IH2 = bisim1AAss1.IH(4)
  note exec = ?exec (ai := e) stk loc pc xcp stk' loc' pc' xcp'
  note bisim1 = P,a,h  (a', xs)  (stk, loc, pc, xcp)
  note bisim2 = P,i,h  (i, loc)  ([], loc, 0, None)
  note len = n + max_vars (a'i := e)  length xs
  note bsok = ‹bsok (ai := e) n
  from bisim1 have pc: "pc  length (compE2 a)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 a)")
    case True
    with exec have exec': "?exec a stk loc pc xcp stk' loc' pc' xcp'" by(simp add: exec_move_AAss1)
    from True have τ: "τmove2 (compP2 P) h stk (ai := e) pc xcp = τmove2 (compP2 P) h stk a pc xcp" by(simp add: τmove2_iff)
    with IH1[OF exec' _ _ P,h  stk [:≤] ST ‹conf_xcp' (compP2 P) h xcp] len bsok obtain e'' xs''
      where bisim': "P,a,h'  (e'', xs'')  (stk', loc', pc', xcp')"
      and red: "?red a' xs e'' xs'' a stk pc pc' xcp xcp'" by auto
    from bisim' have "P,ai := e,h'  (e''i := e, xs'')  (stk', loc', pc', xcp')"
      by(rule bisim1_bisims1.bisim1AAss1)
    moreover from True have "no_call2 (ai := e) pc = no_call2 a pc" by(simp add: no_call2_def)
    ultimately show ?thesis using red τ by(fastforce intro: AAss1Red1 elim!: AAss_τred1r_xt1 AAss_τred1t_xt1)
  next
    case False
    with pc have pc: "pc = length (compE2 a)" by auto
    with bisim1 obtain v where a': "is_val a'  a' = Val v" 
      and stk: "stk = [v]" and xcp: "xcp = None" and call: "call1 a' = None"
      by(auto dest: bisim1_pc_length_compE2D)
    with bisim1 pc len bsok have rede1': "τred1r P t h (a', xs) (Val v, loc)"
      by(auto intro: bisim1_Val_τred1r simp add: bsok_def)
    hence "τred1r P t h (a'i := e, xs) (Val vi := e, loc)" by(rule AAss_τred1r_xt1)
    moreover from pc exec stk xcp
    have exec': "exec_meth_d (compP2 P) (compE2 a @ compE2 i @ compE2 e @ [AStore, Push Unit]) (compxE2 a 0 0 @ shift (length (compE2 a)) (stack_xlift (length [v]) (compxE2 i 0 0) @ shift (length (compE2 i)) (compxE2 e 0 (Suc (Suc 0))))) t h ([] @ [v], loc, length (compE2 a) + 0, None) ta h' (stk', loc', pc', xcp')"
      by(simp add: compxE2_size_convs compxE2_stack_xlift_convs exec_move_def)
    hence "exec_meth_d (compP2 P) (compE2 i @ compE2 e @ [AStore, Push Unit]) (stack_xlift (length [v]) (compxE2 i 0 0) @ shift (length (compE2 i)) (compxE2 e 0 (Suc (Suc 0)))) t h ([] @ [v], loc, 0, None) ta h' (stk', loc', pc' - length (compE2 a), xcp')"
      by(rule exec_meth_drop_xt) auto
    hence "exec_meth_d (compP2 P) (compE2 i) (stack_xlift (length [v]) (compxE2 i 0 0)) t h ([] @ [v], loc, 0, None) ta h' (stk', loc', pc' - length (compE2 a), xcp')"
      by(rule exec_meth_take_xt) simp
    with bisim2 obtain stk'' where stk': "stk' = stk'' @ [v]"
      and exec'': "exec_move_d P t i h ([], loc, 0, None) ta h' (stk'', loc', pc' - length (compE2 a), xcp')"
      unfolding exec_move_def by(blast dest: exec_meth_stk_split)
    with pc xcp have τ: "τmove2 (compP2 P) h [v] (ai:= e) (length (compE2 a)) None = τmove2 (compP2 P) h [] i 0 None"
      using τinstr_stk_drop_exec_move[where stk="[]" and vs="[v]"]
      by(auto simp add: τmove2_iff)
    from bisim1 have "length xs = length loc" by(rule bisim1_length_xs)
    with IH2[OF exec''] len bsok obtain e'' xs''
      where bisim': "P,i,h'  (e'', xs'')  (stk'', loc', pc' - length (compE2 a), xcp')"
      and red: "?red i loc e'' xs'' i [] 0 (pc' - length (compE2 a)) None xcp'" by fastforce
    from bisim'
    have "P,ai := e,h'  (Val ve'' := e, xs'')  (stk'' @ [v], loc', length (compE2 a) + (pc' - length (compE2 a)), xcp')"
      by(rule bisim1_bisims1.bisim1AAss2)
    moreover from red τ have "?red (Val vi := e) loc (Val ve'' := e) xs'' (ai := e) [v] (length (compE2 a)) pc' None xcp'"
      by(fastforce intro: AAss1Red2 elim!: AAss_τred1r_xt2 AAss_τred1t_xt2 split: if_split_asm simp add: no_call2_def)
    moreover from exec' have "pc'  length (compE2 a)"
      by(rule exec_meth_drop_xt_pc) auto
    moreover have "no_call2 (ai := e) pc" using pc by(simp add: no_call2_def)
    ultimately show ?thesis using τ stk' pc xcp stk by(fastforce elim!: rtranclp_trans)
  qed
next
  case (bisim1AAss2 i n i' xs stk loc pc xcp a e v)
  note IH2 = bisim1AAss2.IH(2)
  note IH3 = bisim1AAss2.IH(6)
  note exec = ?exec (ai := e) (stk @ [v]) loc (length (compE2 a) + pc) xcp stk' loc' pc' xcp'
  note bisim2 = P,i,h  (i', xs)  (stk, loc, pc, xcp)
  note bisim3 = P,e,h  (e, loc)  ([], loc, 0, None)
  note len = n + max_vars (Val vi' := e)  length xs
  note bsok = ‹bsok (ai := e) n
  from bisim2 have pc: "pc  length (compE2 i)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 i)")
    case True
    from exec have exec': "exec_meth_d (compP2 P) (compE2 a @ compE2 i @ compE2 e @ [AStore, Push Unit]) (compxE2 a 0 0 @ shift (length (compE2 a)) (stack_xlift (length [v]) (compxE2 i 0 0) @ shift (length (compE2 i)) (compxE2 e 0 (Suc (Suc 0))))) t h (stk @ [v], loc, length (compE2 a) + pc, xcp) ta h' (stk', loc', pc', xcp')"
      by(simp add: shift_compxE2 stack_xlift_compxE2 ac_simps exec_move_def)
    hence "exec_meth_d (compP2 P) (compE2 i @ compE2 e @ [AStore, Push Unit]) (stack_xlift (length [v]) (compxE2 i 0 0) @ shift (length (compE2 i)) (compxE2 e 0 (Suc (Suc 0)))) t h (stk @ [v], loc, pc, xcp) ta h' (stk', loc', pc' - length (compE2 a), xcp')"
      by(rule exec_meth_drop_xt) auto
    hence "exec_meth_d (compP2 P) (compE2 i) (stack_xlift (length [v]) (compxE2 i 0 0)) t h (stk @ [v], loc, pc, xcp) ta h' (stk', loc', pc' - length (compE2 a), xcp')"
      using True by(rule exec_meth_take_xt)
    with bisim2 obtain stk'' where stk': "stk' = stk'' @ [v]"
      and exec'': "exec_move_d P t i h (stk, loc, pc, xcp) ta h' (stk'', loc', pc' - length (compE2 a), xcp')"
      unfolding exec_move_def by(blast dest: exec_meth_stk_split)
    with True have τ: "τmove2 (compP2 P) h (stk @ [v]) (ai := e) (length (compE2 a) + pc) xcp = τmove2 (compP2 P) h stk i pc xcp"
      by(auto simp add: τmove2_iff τinstr_stk_drop_exec_move)
    moreover from P,h  stk @ [v] [:≤] ST obtain ST2 where "P,h  stk [:≤] ST2" by(auto simp add: list_all2_append1)
    from IH2[OF exec'' _ _ this ‹conf_xcp' (compP2 P) h xcp] len bsok obtain e'' xs''
      where bisim': "P,i,h'  (e'', xs'')  (stk'', loc', pc' - length (compE2 a), xcp')"
      and red: "?red i' xs e'' xs'' i stk pc (pc' - length (compE2 a)) xcp xcp'" by fastforce
    from bisim'
    have "P,ai := e,h'  (Val ve'' := e, xs'')  (stk'' @ [v], loc', length (compE2 a) + (pc' - length (compE2 a)), xcp')"
      by(rule bisim1_bisims1.bisim1AAss2)
    moreover from exec' have "pc'  length (compE2 a)"
      by(rule exec_meth_drop_xt_pc) auto
    moreover have "no_call2 i pc  no_call2 (ai := e) (length (compE2 a) + pc)" by(simp add: no_call2_def)
    ultimately show ?thesis using red τ stk' True
      by(fastforce intro: AAss1Red2 elim!: AAss_τred1r_xt2 AAss_τred1t_xt2 split: if_split_asm)
  next
    case False
    with pc have [simp]: "pc = length (compE2 i)" by simp
    with bisim2 obtain v2 where i': "is_val i'  i' = Val v2" 
      and stk: "stk = [v2]" and xcp: "xcp = None" and call: "call1 i' = None"
      by(auto dest: bisim1_pc_length_compE2D)
    with bisim2 pc len bsok have red: "τred1r P t h (i', xs) (Val v2, loc)"
      by(auto intro: bisim1_Val_τred1r simp add: bsok_def)
    hence "τred1r P t h (Val vi' := e, xs) (Val vVal v2 := e, loc)" by(rule AAss_τred1r_xt2)
    moreover from pc exec stk xcp
    have exec': "exec_meth_d (compP2 P) ((compE2 a @ compE2 i) @ compE2 e @ [AStore, Push Unit]) ((compxE2 a 0 0 @ compxE2 i (length (compE2 a)) (Suc 0)) @ shift (length (compE2 a @ compE2 i)) (stack_xlift (length [v2, v]) (compxE2 e 0 0))) t h ([] @ [v2, v], loc, length (compE2 a @ compE2 i) + 0, None) ta h' (stk', loc', pc', xcp')"
      by(simp add: compxE2_size_convs compxE2_stack_xlift_convs exec_move_def)
    hence "exec_meth_d (compP2 P) (compE2 e @ [AStore, Push Unit]) (stack_xlift (length [v2, v]) (compxE2 e 0 0)) t h ([] @ [v2, v], loc, 0, None) ta h' (stk', loc', pc' - length (compE2 a @ compE2 i), xcp')"
      by(rule exec_meth_drop_xt) auto
    hence "exec_meth_d (compP2 P) (compE2 e) (stack_xlift (length [v2, v]) (compxE2 e 0 0)) t h ([] @ [v2, v], loc, 0, None) ta h' (stk', loc', pc' - length (compE2 a @ compE2 i), xcp')"
      by(rule exec_meth_take) simp
    with bisim3 obtain stk'' where stk': "stk' = stk'' @ [v2, v]"
      and exec'': "exec_move_d P t e h ([], loc, 0, None) ta h' (stk'', loc', pc' - length (compE2 a @ compE2 i), xcp')"
      unfolding exec_move_def by(blast dest: exec_meth_stk_split)
    with pc xcp have τ: "τmove2 (compP2 P) h [v2, v] (ai:= e) (length (compE2 a) + length (compE2 i)) None = τmove2 (compP2 P) h [] e 0 None"
      using τinstr_stk_drop_exec_move[where stk="[]" and vs="[v2, v]"] by(simp add: τmove2_iff)
    from bisim2 have "length xs = length loc" by(rule bisim1_length_xs)
    with IH3[OF exec'', of "[]"] len bsok obtain e'' xs''
      where bisim': "P,e,h'  (e'', xs'')  (stk'', loc', pc' - length (compE2 a) - length (compE2 i), xcp')"
      and red: "?red e loc e'' xs'' e [] 0 (pc' - length (compE2 a) - length (compE2 i)) None xcp'"
      by auto (fastforce simp only: length_append diff_diff_left)
    from bisim'
    have "P,ai := e,h'  (Val vVal v2 := e'', xs'')  (stk'' @ [v2, v], loc', length (compE2 a) + length (compE2 i) + (pc' - length (compE2 a) - length (compE2 i)), xcp')"
      by(rule bisim1_bisims1.bisim1AAss3)
    moreover from red τ
    have "?red (Val vVal v2 := e) loc (Val vVal v2 := e'') xs'' (ai := e) [v2, v] (length (compE2 a) + length (compE2 i)) pc' None xcp'"
      by(fastforce intro: AAss1Red3 elim!: AAss_τred1r_xt3 AAss_τred1t_xt3 split: if_split_asm simp add: no_call2_def)
    moreover from exec' have "pc'  length (compE2 a @ compE2 i)"
      by(rule exec_meth_drop_xt_pc) auto
    moreover have "no_call2 (ai := e) (length (compE2 a) + pc)" by(simp add: no_call2_def)
    ultimately show ?thesis using τ stk' pc xcp stk by(fastforce elim!: rtranclp_trans)
  qed
next
  case (bisim1AAss3 e n e' xs stk loc pc xcp a i v v')
  note IH3 = bisim1AAss3.IH(2)
  note exec = ?exec (ai := e) (stk @ [v', v]) loc (length (compE2 a) + length (compE2 i) + pc) xcp stk' loc' pc' xcp'
  note bisim3 = P,e,h  (e', xs)  (stk, loc, pc, xcp)
  note len = n + max_vars (Val vVal v' := e')  length xs
  note bsok = ‹bsok (ai := e) n
  from P,h  stk @ [v', v] [:≤] ST obtain T T' ST'
    where [simp]: "ST = ST' @ [T', T]"
    and wtv: "P,h  v :≤ T" and wtv': "P,h  v' :≤ T'" and ST': "P,h  stk [:≤] ST'"
    by(auto simp add: list_all2_Cons1 list_all2_append1)
  from bisim3 have pc: "pc  length (compE2 e)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e)")
    case True
    from exec have exec': "exec_meth_d (compP2 P) ((compE2 a @ compE2 i) @ compE2 e @ [AStore, Push Unit]) ((compxE2 a 0 0 @ compxE2 i (length (compE2 a)) (Suc 0)) @ shift (length (compE2 a @ compE2 i)) (stack_xlift (length [v', v]) (compxE2 e 0 0))) t h (stk @ [v', v], loc, length (compE2 a @ compE2 i) + pc, xcp) ta h' (stk', loc', pc', xcp')"
      by(simp add: shift_compxE2 stack_xlift_compxE2 exec_move_def)
    hence "exec_meth_d (compP2 P) (compE2 e @ [AStore, Push Unit]) (stack_xlift (length [v', v]) (compxE2 e 0 0)) t h (stk @ [v', v], loc, pc, xcp) ta h' (stk', loc', pc' - length (compE2 a @ compE2 i), xcp')"
      by(rule exec_meth_drop_xt) auto
    hence "exec_meth_d (compP2 P) (compE2 e) (stack_xlift (length [v', v]) (compxE2 e 0 0)) t h (stk @ [v', v], loc, pc, xcp) ta h' (stk', loc', pc' - length (compE2 a @ compE2 i), xcp')"
      using True by(rule exec_meth_take)
    with bisim3 obtain stk'' where stk': "stk' = stk'' @ [v', v]"
      and exec'': "exec_move_d P t e h (stk, loc, pc, xcp) ta h' (stk'', loc', pc' - length (compE2 a @ compE2 i), xcp')"
      unfolding exec_move_def by(blast dest: exec_meth_stk_split)
    with True have τ: "τmove2 (compP2 P) h (stk @ [v', v]) (ai := e) (length (compE2 a) + length (compE2 i) + pc) xcp = τmove2 (compP2 P) h stk e pc xcp"
      by(auto simp add: τmove2_iff τinstr_stk_drop_exec_move)
    moreover from IH3[OF exec'' _ _ ST' ‹conf_xcp' (compP2 P) h xcp] len bsok obtain e'' xs''
      where bisim': "P,e,h'  (e'', xs'')  (stk'', loc', pc' - length (compE2 a) - length (compE2 i), xcp')"
      and red: "?red e' xs e'' xs'' e stk pc (pc' - length (compE2 a) - length (compE2 i)) xcp xcp'"
      by auto(fastforce simp only: length_append diff_diff_left)
    from bisim'
    have "P,ai := e,h'  (Val vVal v' := e'', xs'')  (stk'' @ [v', v], loc', length (compE2 a) + length (compE2 i) + (pc' - length (compE2 a) - length (compE2 i)), xcp')"
      by(rule bisim1_bisims1.bisim1AAss3)
    moreover from exec' have "pc'  length (compE2 a @ compE2 i)"
      by(rule exec_meth_drop_xt_pc) auto
    moreover have "no_call2 e pc  no_call2 (ai := e) (length (compE2 a) + length (compE2 i) + pc)"
      by(simp add: no_call2_def)
    ultimately show ?thesis using red τ stk' True
      by(fastforce intro: AAss1Red3 elim!: AAss_τred1r_xt3 AAss_τred1t_xt3 split: if_split_asm)
  next
    case False
    with pc have [simp]: "pc = length (compE2 e)" by simp
    with bisim3 obtain v2 where stk: "stk = [v2]" and xcp: "xcp = None"
      by(auto dest: bisim1_pc_length_compE2D)
    with bisim3 pc len bsok have red: "τred1r P t h (e', xs) (Val v2, loc)" 
      by(auto intro: bisim1_Val_τred1r simp add: bsok_def)
    hence "τred1r P t h (Val vVal v' := e', xs) (Val vVal v' := Val v2, loc)" by(rule AAss_τred1r_xt3)
    moreover have τ: "¬ τmove2 (compP2 P) h [v2, v', v] (ai := e) (length (compE2 a) + length (compE2 i) + length (compE2 e)) None"
      by(simp add: τmove2_iff)
    moreover 
    have "ta' e''. P,ai := e,h'  (e'',loc)  (stk', loc', pc', xcp')  True,P,t ⊢1 Val vVal v' := Val v2, (h, loc) -ta' e'',(h', loc)  ta_bisim wbisim1 (extTA2J1 P ta') ta"
    proof(cases "v = Null")
      case True with exec stk xcp show ?thesis
        by(fastforce elim!: exec_meth.cases simp add: exec_move_def intro: bisim1AAssFail Red1AAssNull)
    next
      case False
      with exec stk xcp  obtain U A len I where [simp]: "v = Addr A" "v' = Intg I"
        and hA: "typeof_addr h A = Array_type U len"
        by(fastforce simp add: exec_move_def exec_meth_instr is_Ref_def)
      from ST' stk obtain T3 where wt3': "typeofh v2 = T3" by(auto simp add: list_all2_Cons1 conf_def)
      show ?thesis
      proof(cases "0 <=s I  sint I < int len")
        case True
        note I = True
        show ?thesis
        proof(cases "P  T3  U")
          case True
          with exec stk xcp True hA I wt3' show ?thesis
            by(fastforce elim!: exec_meth.cases simp add: compP2_def exec_move_def ta_bisim_def ta_upd_simps intro: Red1AAss bisim1AAss4 split: if_split_asm)
        next
          case False
          with exec stk xcp True hA I wt3' show ?thesis
            by(fastforce elim!: exec_meth.cases simp add: compP2_def exec_move_def intro: Red1AAssStore bisim1AAssFail split: if_split_asm)
        qed
      next
        case False
        with exec stk xcp hA show ?thesis
          by(fastforce elim!: exec_meth.cases intro: bisim1AAssFail Red1AAssBounds simp add: exec_move_def split: if_split_asm)
      qed
    qed
    ultimately show ?thesis using exec xcp stk by(fastforce simp add: no_call2_def)
  qed
next
  case (bisim1AAssThrow1 A n a xs stk loc pc i e)
  note exec = ?exec (Ai := e) stk loc pc a stk' loc' pc' xcp'
  note bisim1 = P,A,h  (Throw a, xs)  (stk, loc, pc, a)
  from bisim1 have pc: "pc < length (compE2 A)" by(auto dest: bisim1_ThrowD)
  from bisim1 have "match_ex_table (compP2 P) (cname_of h a) (0 + pc) (compxE2 A 0 0) = None"
    unfolding compP2_def by(rule bisim1_xcp_Some_not_caught)
  with exec pc have False
    by(auto elim!: exec_meth.cases simp add: match_ex_table_not_pcs_None exec_move_def)
  thus ?case ..
next
  case (bisim1AAssThrow2 i n a xs stk loc pc A e v)
  note exec = ?exec (Ai := e) (stk @ [v]) loc (length (compE2 A) + pc) a stk' loc' pc' xcp'
  note bisim2 = P,i,h  (Throw a, xs)  (stk, loc, pc, a)
  from bisim2 have pc: "pc < length (compE2 i)" by(auto dest: bisim1_ThrowD)
  from bisim2 have "match_ex_table (compP2 P) (cname_of h a) (length (compE2 A) + pc) (compxE2 i (length (compE2 A)) 0) = None"
    unfolding compP2_def by(rule bisim1_xcp_Some_not_caught)
  with exec pc have False
    apply(auto elim!: exec_meth.cases simp add: compxE2_stack_xlift_convs compxE2_size_convs exec_move_def)
    apply(auto simp add: match_ex_table_append_not_pcs)
    done
  thus ?case .. 
next
  case (bisim1AAssThrow3 e n a xs stk loc pc A i v' v)
  note exec = ?exec (Ai := e) (stk @ [v', v]) loc (length (compE2 A) + length (compE2 i) + pc) a stk' loc' pc' xcp'
  note bisim2 = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  from bisim2 have "match_ex_table (compP2 P) (cname_of h a) (length (compE2 A) + length (compE2 i) + pc) (compxE2 e (length (compE2 A) + length (compE2 i)) 0) = None"
    unfolding compP2_def by(rule bisim1_xcp_Some_not_caught)
  with exec have False
    apply(auto elim!: exec_meth.cases simp add: compxE2_stack_xlift_convs compxE2_size_convs exec_move_def)
    apply(auto dest!: match_ex_table_stack_xliftD match_ex_table_shift_pcD dest: match_ex_table_pcsD simp add: match_ex_table_append match_ex_table_shift_pc_None)
    done
  thus ?case .. 
next
  case (bisim1AAssFail a n i e ad xs v' v v'')
  note exec = ?exec (ai := e) [v', v, v''] xs (length (compE2 a) + length (compE2 i) + length (compE2 e)) ad stk' loc' pc' xcp'
  hence False
    by(auto elim!: exec_meth.cases simp add: match_ex_table_append exec_move_def
            dest!: match_ex_table_shift_pcD match_ex_table_pc_length_compE2)
  thus ?case ..
next
  case (bisim1AAss4 a n i e xs)
  have "P,ai := e,h  (unit, xs)  ([Unit], xs, length (compE2 (ai := e)), None)" by(rule bisim1Val2) simp
  moreover have "τmove2 (compP2 P) h [] (ai := e) (Suc (length (compE2 a) + length (compE2 i) + length (compE2 e))) None"
    by(simp add: τmove2_iff)
  moreover note ?exec (ai := e) [] xs (Suc (length (compE2 a) + length (compE2 i) + length (compE2 e))) None stk' loc' pc' xcp'
  ultimately show ?case
    by(fastforce elim!: exec_meth.cases simp add: ac_simps exec_move_def)
next
  case (bisim1ALength a n a' xs stk loc pc xcp)
  note IH = bisim1ALength.IH(2)
  note exec = ?exec (a∙length) stk loc pc xcp stk' loc' pc' xcp'
  note bisim = P,a,h  (a', xs)  (stk, loc, pc, xcp)
  note len = n + max_vars (a'∙length)  length xs
  note bsok = ‹bsok (a∙length) n
  from bisim have pc: "pc  length (compE2 a)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 a)")
    case True
    with exec have exec': "?exec a stk loc pc xcp stk' loc' pc' xcp'" by(auto simp add: exec_move_ALength)
    from True have τ: "τmove2 (compP2 P) h stk (a∙length) pc xcp = τmove2 (compP2 P) h stk a pc xcp" by(simp add: τmove2_iff)
    with IH[OF exec' _ _ P,h  stk [:≤] ST ‹conf_xcp' (compP2 P) h xcp] len bsok obtain e'' xs''
      where bisim': "P,a,h'  (e'', xs'')  (stk', loc', pc', xcp')"
      and red: "?red a' xs e'' xs'' a stk pc pc' xcp xcp'" by auto
    from bisim' have "P,a∙length,h'  (e''∙length, xs'')  (stk', loc', pc', xcp')"
      by(rule bisim1_bisims1.bisim1ALength)
    with red τ show ?thesis by(fastforce intro: ALength1Red elim!: ALength_τred1r_xt ALength_τred1t_xt simp add: no_call2_def)
  next
    case False
    with pc have pc: "pc = length (compE2 a)" by auto
    with bisim obtain v where stk: "stk = [v]" and xcp: "xcp = None"
      by(auto dest: bisim1_pc_length_compE2D)
    with bisim pc len bsok have "τred1r P t h (a', xs) (Val v, loc)"
      by(auto intro: bisim1_Val_τred1r simp add: bsok_def)
    hence "τred1r P t h (a'∙length, xs) (Val v∙length, loc)" by(rule ALength_τred1r_xt)
    moreover
    moreover have τ: "¬ τmove2 (compP2 P) h [v] (a∙length) (length (compE2 a)) None" by(simp add: τmove2_iff)
    moreover have "ta' e''. P,a∙length,h'  (e'',loc)  (stk', loc', pc', xcp')  True,P,t ⊢1 Val v∙length, (h, loc) -ta' e'',(h', loc)  ta_bisim wbisim1 (extTA2J1 P ta') ta"
    proof(cases "v = Null")
      case True with exec stk xcp pc show ?thesis
        by(fastforce elim!: exec_meth.cases simp add: exec_move_def intro: bisim1ALengthNull Red1ALengthNull)
    next
      case False
      with exec stk xcp pc P,h  stk [:≤] ST
      obtain U A len where [simp]: "v = Addr A"
        and hA: "typeof_addr h A = Array_type U len"
        by(fastforce simp add: exec_move_def exec_meth_instr is_Ref_def list_all2_Cons1)
      have "P,a∙length,h'  (Val (Intg (word_of_int (int len))),loc)  ([Intg (word_of_int (int len))], loc, length (compE2 (a∙length)), None)"
        by(rule bisim1Val2) simp
      thus ?thesis using exec stk xcp hA pc
        by(fastforce elim!: exec_meth.cases intro: Red1ALength simp add: exec_move_def)
    qed
    ultimately show ?thesis using τ pc xcp stk by(fastforce elim!: rtranclp_trans simp add: no_call2_def)
  qed
next
  case (bisim1ALengthThrow A n a xs stk loc pc)
  note exec = ?exec (A∙length) stk loc pc a stk' loc' pc' xcp'
  note bisim1 = P,A,h  (Throw a, xs)  (stk, loc, pc, a)
  from bisim1 have pc: "pc < length (compE2 A)" by(auto dest: bisim1_ThrowD)
  from bisim1 have "match_ex_table (compP2 P) (cname_of h a) (0 + pc) (compxE2 A 0 0) = None"
    unfolding compP2_def by(rule bisim1_xcp_Some_not_caught)
  with exec pc have False by(auto elim!: exec_meth.cases simp add: exec_move_def)
  thus ?case ..
next
  case (bisim1ALengthNull a n xs)
  note exec = ?exec (a∙length) [Null] xs (length (compE2 a)) addr_of_sys_xcpt NullPointer stk' loc' pc' xcp'
  hence False by(auto elim!: exec_meth.cases dest!: match_ex_table_pc_length_compE2 simp add: exec_move_def)
  thus ?case ..
next
  case (bisim1FAcc e n e' xs stk loc pc xcp F D)
  note IH = bisim1FAcc.IH(2)
  note exec = ?exec (eF{D}) stk loc pc xcp stk' loc' pc' xcp'
  note bisim = P,e,h  (e', xs)  (stk, loc, pc, xcp)
  note len = n + max_vars (e'F{D})  length xs
  note bsok = ‹bsok (eF{D}) n
  from bisim have pc: "pc  length (compE2 e)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e)")
    case True
    with exec have exec': "?exec e stk loc pc xcp stk' loc' pc' xcp'" by(simp add: exec_move_FAcc)
    from True have τ: "τmove2 (compP2 P) h stk (eF{D}) pc xcp = τmove2 (compP2 P) h stk e pc xcp" by(simp add: τmove2_iff)
    with IH[OF exec' _ _ P,h  stk [:≤] ST ‹conf_xcp' (compP2 P) h xcp] len bsok obtain e'' xs''
      where bisim': "P,e,h'  (e'', xs'')  (stk', loc', pc', xcp')"
      and red: "?red e' xs e'' xs'' e stk pc pc' xcp xcp'" by auto
    from bisim' have "P,eF{D},h'  (e''F{D}, xs'')  (stk', loc', pc', xcp')"
      by(rule bisim1_bisims1.bisim1FAcc)
    with red τ show ?thesis by(fastforce intro: FAcc1Red elim!: FAcc_τred1r_xt FAcc_τred1t_xt simp add: no_call2_def)
  next
    case False
    with pc have pc: "pc = length (compE2 e)" by auto
    with bisim obtain v where stk: "stk = [v]" and xcp: "xcp = None"
      by(auto dest: bisim1_pc_length_compE2D)
    with bisim pc len bsok have "τred1r P t h (e', xs) (Val v, loc)"
      by(auto intro: bisim1_Val_τred1r simp add: bsok_def)
    hence "τred1r P t h (e'F{D}, xs) (Val vF{D}, loc)" by(rule FAcc_τred1r_xt)
    moreover have τ: "¬ τmove2 (compP2 P) h [v] (eF{D}) (length (compE2 e)) None" by(simp add: τmove2_iff)
    moreover have "ta' e''. P,eF{D},h'  (e'',loc)  (stk', loc', pc', xcp')  True,P,t ⊢1 Val vF{D}, (h, loc) -ta' e'',(h', loc)  ta_bisim wbisim1 (extTA2J1 P ta') ta"
    proof(cases "v = Null")
      case True with exec stk xcp pc show ?thesis
        by(fastforce elim!: exec_meth.cases simp add: exec_move_def intro: bisim1FAccNull Red1FAccNull)
    next
      case False
      with exec stk xcp pc P,h  stk [:≤] ST
      obtain A where [simp]: "v = Addr A"
        by(fastforce simp add: exec_move_def exec_meth_instr is_Ref_def compP2_def)
      from exec False pc stk xcp obtain v' where v': "heap_read h A (CField D F) v'" "stk' = [v']"
        by(auto simp add: exec_move_def exec_meth_instr)
      have "P,eF{D},h'  (Val v',loc)  ([v'], loc, length (compE2 (eF{D})), None)"
        by(rule bisim1Val2) simp
      thus ?thesis using exec stk xcp pc v'
        by(fastforce elim!: exec_meth.cases intro: Red1FAcc simp add: exec_move_def ta_upd_simps ta_bisim_def)
    qed
    ultimately show ?thesis using τ pc xcp stk by(fastforce elim!: rtranclp_trans simp add: no_call2_def)
  qed
next
  case (bisim1FAccThrow e n a xs stk loc pc F D)
  note exec = ?exec (eF{D}) stk loc pc a stk' loc' pc' xcp'
  note bisim1 = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  from bisim1 have pc: "pc < length (compE2 e)" by(auto dest: bisim1_ThrowD)
  from bisim1 have "match_ex_table (compP2 P) (cname_of h a) (0 + pc) (compxE2 e 0 0) = None"
    unfolding compP2_def by(rule bisim1_xcp_Some_not_caught)
  with exec pc have False by(auto elim!: exec_meth.cases simp add: exec_move_def)
  thus ?case ..
next
  case (bisim1FAccNull e n F D xs)
  note exec = ?exec (eF{D}) [Null] xs (length (compE2 e)) addr_of_sys_xcpt NullPointer stk' loc' pc' xcp'
  hence False by(auto elim!: exec_meth.cases dest!: match_ex_table_pc_length_compE2 simp add: exec_move_def)
  thus ?case ..
next
  case (bisim1FAss1 e n e' xs stk loc pc xcp e2 F D)
  note IH1 = bisim1FAss1.IH(2)
  note IH2 = bisim1FAss1.IH(4)
  note exec = ?exec (eF{D} := e2) stk loc pc xcp stk' loc' pc' xcp'
  note bisim1 = P,e,h  (e', xs)  (stk, loc, pc, xcp)
  note bisim2 = P,e2,h  (e2, loc)  ([], loc, 0, None)
  note len = n + max_vars (e'F{D} := e2)  length xs
  note bsok = ‹bsok (eF{D} := e2) n
  from bisim1 have pc: "pc  length (compE2 e)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e)")
    case True
    with exec have exec': "?exec e stk loc pc xcp stk' loc' pc' xcp'" by(simp add: exec_move_FAss1)
    from True have τ: "τmove2 (compP2 P) h stk (eF{D} := e2) pc xcp = τmove2 (compP2 P) h stk e pc xcp"
      by(simp add: τmove2_iff)
    with IH1[OF exec' _ _ P,h  stk [:≤] ST ‹conf_xcp' (compP2 P) h xcp] len bsok obtain e'' xs''
      where bisim': "P,e,h'  (e'', xs'')  (stk', loc', pc', xcp')"
      and red: "?red e' xs e'' xs'' e stk pc pc' xcp xcp'" by auto
    from bisim' have "P,eF{D} := e2,h'  (e''F{D} := e2, xs'')  (stk', loc', pc', xcp')"
      by(rule bisim1_bisims1.bisim1FAss1)
    with red τ show ?thesis by(fastforce intro: FAss1Red1 elim!: FAss_τred1r_xt1 FAss_τred1t_xt1 simp add: no_call2_def)
  next
    case False
    with pc have pc: "pc = length (compE2 e)" by auto
    with bisim1 obtain v where stk: "stk = [v]" and xcp: "xcp = None"
      by(auto dest: bisim1_pc_length_compE2D)
    with bisim1 pc len bsok have rede1': "τred1r P t h (e', xs) (Val v, loc)" 
      by(auto intro: bisim1_Val_τred1r simp add: bsok_def)
    hence "τred1r P t h (e'F{D} := e2, xs) (Val vF{D} := e2, loc)" by(rule FAss_τred1r_xt1)
    moreover from pc exec stk xcp
    have exec': "exec_meth_d (compP2 P) (compE2 e @ compE2 e2 @ [Putfield F D, Push Unit]) (compxE2 e 0 0 @ shift (length (compE2 e)) (stack_xlift (length [v]) (compxE2 e2 0 0))) t h ([] @ [v], loc, length (compE2 e) + 0, None) ta h' (stk', loc', pc', xcp')"
      by(simp add: compxE2_size_convs compxE2_stack_xlift_convs exec_move_def)
    hence "exec_meth_d (compP2 P) (compE2 e2 @ [Putfield F D, Push Unit]) (stack_xlift (length [v]) (compxE2 e2 0 0)) t h ([] @ [v], loc, 0, None) ta h' (stk', loc', pc' - length (compE2 e), xcp')"
      by(rule exec_meth_drop_xt) auto
    hence "exec_meth_d (compP2 P) (compE2 e2) (stack_xlift (length [v]) (compxE2 e2 0 0)) t h ([] @ [v], loc, 0, None) ta h' (stk', loc', pc' - length (compE2 e), xcp')"
      by(rule exec_meth_take) simp
    with bisim2 obtain stk'' where stk': "stk' = stk'' @ [v]"
      and exec'': "exec_move_d P t e2 h ([], loc, 0, None) ta h' (stk'', loc', pc' - length (compE2 e), xcp')"
      unfolding exec_move_def by(blast dest: exec_meth_stk_split)
    with pc xcp have τ: "τmove2 (compP2 P) h [v] (eF{D} := e2) (length (compE2 e)) None = τmove2 (compP2 P) h [] e2 0 None"
      using τinstr_stk_drop_exec_move[where stk="[]" and vs = "[v]"] by(simp add: τmove2_iff)
    from bisim1 have "length xs = length loc" by(rule bisim1_length_xs)
    with IH2[OF exec'', of "[]"] len bsok obtain e'' xs''
      where bisim': "P,e2,h'  (e'', xs'')  (stk'', loc', pc' - length (compE2 e), xcp')"
      and red: "?red e2 loc e'' xs'' e2 [] 0 (pc' - length (compE2 e)) None xcp'" by auto
    from bisim' 
    have "P,eF{D} := e2,h'  (Val vF{D} := e'', xs'')  (stk'' @ [v], loc', length (compE2 e) + (pc' - length (compE2 e)), xcp')"
      by(rule bisim1_bisims1.bisim1FAss2)
    moreover from red τ 
    have "?red (Val vF{D} := e2) loc (Val vF{D} := e'') xs'' (eF{D} := e2) [v] (length (compE2 e)) pc' None xcp'"
      by(fastforce intro: FAss1Red2 elim!: FAss_τred1r_xt2 FAss_τred1t_xt2 split: if_split_asm simp add: no_call2_def)
    moreover from exec' have "pc'  length (compE2 e)"
      by(rule exec_meth_drop_xt_pc) auto
    moreover have "no_call2 (eF{D} := e2) pc" using pc by(simp add: no_call2_def)
    ultimately show ?thesis using τ stk' pc xcp stk by(fastforce elim!: rtranclp_trans)
  qed
next
  case (bisim1FAss2 e2 n e' xs stk loc pc xcp e F D v)
  note IH2 = bisim1FAss2.IH(2)
  note exec = ?exec (eF{D} := e2) (stk @ [v]) loc (length (compE2 e) + pc) xcp stk' loc' pc' xcp'
  note bisim2 = P,e2,h  (e', xs)  (stk, loc, pc, xcp)
  note len = n + max_vars (Val vF{D} := e')  length xs
  note bsok = ‹bsok (eF{D} := e2) n
  note ST = P,h  stk @ [v] [:≤] ST
  then obtain T ST' where ST': "P,h  stk [:≤] ST'" and T: "typeofh v = T"
    by(auto simp add: list_all2_append1 list_all2_Cons1 conf_def)

  from bisim2 have pc: "pc  length (compE2 e2)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e2)")
    case True
    from exec have exec': "exec_meth_d (compP2 P) (compE2 e @ compE2 e2 @ [Putfield F D, Push Unit]) (compxE2 e 0 0 @ shift (length (compE2 e)) (stack_xlift (length [v]) (compxE2 e2 0 0))) t h (stk @ [v], loc, length (compE2 e) + pc, xcp) ta h' (stk', loc', pc', xcp')"
      by(simp add: shift_compxE2 stack_xlift_compxE2 exec_move_def)
    hence "exec_meth_d (compP2 P) (compE2 e2 @ [Putfield F D, Push Unit]) (stack_xlift (length [v]) (compxE2 e2 0 0)) t h (stk @ [v], loc, pc, xcp) ta h' (stk', loc', pc' - length (compE2 e), xcp')"
      by(rule exec_meth_drop_xt) auto
    hence "exec_meth_d (compP2 P) (compE2 e2) (stack_xlift (length [v]) (compxE2 e2 0 0)) t h (stk @ [v], loc, pc, xcp) ta h' (stk', loc', pc' - length (compE2 e), xcp')"
      using True by(rule exec_meth_take)
    with bisim2 obtain stk'' where stk': "stk' = stk'' @ [v]"
      and exec'': "exec_move_d P t e2 h (stk, loc, pc, xcp) ta h' (stk'', loc', pc' - length (compE2 e), xcp')"
      unfolding exec_move_def by(blast dest: exec_meth_stk_split)
    with True have τ: "τmove2 (compP2 P) h (stk @ [v]) (eF{D} := e2) (length (compE2 e) + pc) xcp = τmove2 (compP2 P) h stk e2 pc xcp"
      by(auto simp add: τmove2_iff τinstr_stk_drop_exec_move)
    moreover from IH2[OF exec'' _ _ ST' ‹conf_xcp' (compP2 P) h xcp] len bsok obtain e'' xs''
      where bisim': "P,e2,h'  (e'', xs'')  (stk'', loc', pc' - length (compE2 e), xcp')"
      and red: "?red e' xs e'' xs'' e2 stk pc (pc' - length (compE2 e)) xcp xcp'" by auto
    from bisim' have "P,eF{D} := e2,h'  (Val vF{D} := e'', xs'')  (stk'' @ [v], loc', length (compE2 e) + (pc' - length (compE2 e)), xcp')"
      by(rule bisim1_bisims1.bisim1FAss2)
    moreover from exec' have "pc'  length (compE2 e)"
      by(rule exec_meth_drop_xt_pc) auto
    ultimately show ?thesis using red τ stk' True
      by(fastforce intro: FAss1Red2 elim!: FAss_τred1r_xt2 FAss_τred1t_xt2 split: if_split_asm simp add: no_call2_def)
  next
    case False
    with pc have [simp]: "pc = length (compE2 e2)" by simp
    with bisim2 obtain v2 where stk: "stk = [v2]" and xcp: "xcp = None"
      by(auto dest: bisim1_pc_length_compE2D)
    with bisim2 pc len bsok have red: "τred1r P t h (e', xs) (Val v2, loc)"
      by(auto intro: bisim1_Val_τred1r simp add: bsok_def)
    hence "τred1r P t h (Val vF{D} := e', xs) (Val vF{D} := Val v2, loc)" by(rule FAss_τred1r_xt2)
    moreover have τ: "¬ τmove2 (compP2 P) h [v2, v] (eF{D} := e2) (length (compE2 e) + length (compE2 e2)) None" by(simp add: τmove2_iff)
    moreover
    have "ta' e''. P,eF{D} := e2,h'  (e'',loc)  (stk', loc', pc', xcp')  True,P,t ⊢1 Val vF{D} := Val v2, (h, loc) -ta' e'',(h', loc)  ta_bisim wbisim1 (extTA2J1 P ta') ta"
    proof(cases "v = Null")
      case True with exec stk xcp show ?thesis
        by(fastforce elim!: exec_meth.cases simp add: exec_move_def intro: bisim1FAssNull Red1FAssNull)
    next
      case False with exec stk xcp T show ?thesis
        by(fastforce simp add: exec_move_def compP2_def exec_meth_instr is_Ref_def ta_upd_simps ta_bisim_def intro: bisim1FAss3 Red1FAss)
    qed
    ultimately show ?thesis using exec xcp stk by(fastforce simp add: no_call2_def)
  qed
next
  case (bisim1FAssThrow1 e n a xs stk loc pc e2 F D)
  note exec = ?exec (eF{D} := e2) stk loc pc a stk' loc' pc' xcp'
  note bisim1 = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  from bisim1 have pc: "pc < length (compE2 e)" by(auto dest: bisim1_ThrowD)
  from bisim1 have "match_ex_table (compP2 P) (cname_of h a) (0 + pc) (compxE2 e 0 0) = None"
    unfolding compP2_def by(rule bisim1_xcp_Some_not_caught)
  with exec pc have False
    by(auto elim!: exec_meth.cases simp add: exec_move_def match_ex_table_not_pcs_None)
  thus ?case ..
next
  case (bisim1FAssThrow2 e2 n a xs stk loc pc e F D v)
  note exec = ?exec (eF{D} := e2) (stk @ [v]) loc (length (compE2 e) + pc) a stk' loc' pc' xcp'
  note bisim2 = P,e2,h  (Throw a, xs)  (stk, loc, pc, a)
  hence "match_ex_table (compP2 P) (cname_of h a) (length (compE2 e) + pc) (compxE2 e2 (length (compE2 e)) 0) = None"
    unfolding compP2_def by(rule bisim1_xcp_Some_not_caught)
  with exec have False
    by(auto elim!: exec_meth.cases simp add: compxE2_stack_xlift_convs exec_move_def)(auto dest!: match_ex_table_stack_xliftD simp add: match_ex_table_append_not_pcs)
  thus ?case ..
next
  case (bisim1FAssNull e n e2 F D xs v)
  note exec = ?exec (eF{D} := e2) [v, Null] xs (length (compE2 e) + length (compE2 e2)) addr_of_sys_xcpt NullPointer stk' loc' pc' xcp'
  hence False
    by(auto elim!: exec_meth.cases simp add: match_ex_table_append_not_pcs compxE2_size_convs exec_move_def
               dest!: match_ex_table_shift_pcD match_ex_table_pc_length_compE2)
  thus ?case ..
next
  case (bisim1FAss3 e n e2 F D xs)
  have "P,eF{D} := e2,h  (unit, xs)  ([Unit], xs, length (compE2 (eF{D} := e2)), None)" by(rule bisim1Val2) simp
  moreover have "τmove2 (compP2 P) h [] (eF{D} := e2) (Suc (length (compE2 e) + length (compE2 e2))) None" by(simp add: τmove2_iff)
  moreover note ?exec (eF{D} := e2) [] xs (Suc (length (compE2 e) + length (compE2 e2))) None stk' loc' pc' xcp'
  ultimately show ?case
    by(fastforce elim!: exec_meth.cases simp add: ac_simps exec_move_def)
next
  case (bisim1CAS1 a n a' xs stk loc pc xcp i e D F)
  note IH1 = bisim1CAS1.IH(2)
  note IH2 = bisim1CAS1.IH(4)
  note exec = ?exec (a∙compareAndSwap(DF, i, e)) stk loc pc xcp stk' loc' pc' xcp'
  note bisim1 = P,a,h  (a', xs)  (stk, loc, pc, xcp)
  note bisim2 = P,i,h  (i, loc)  ([], loc, 0, None)
  note len = n + max_vars _  length xs
  note bsok = ‹bsok (a∙compareAndSwap(DF, i, e)) n
  from bisim1 have pc: "pc  length (compE2 a)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 a)")
    case True
    with exec have exec': "?exec a stk loc pc xcp stk' loc' pc' xcp'" by(simp add: exec_move_CAS1)
    from True have τ: "τmove2 (compP2 P) h stk (a∙compareAndSwap(DF, i, e)) pc xcp = τmove2 (compP2 P) h stk a pc xcp" by(simp add: τmove2_iff)
    with IH1[OF exec' _ _ P,h  stk [:≤] ST ‹conf_xcp' (compP2 P) h xcp] len bsok obtain e'' xs''
      where bisim': "P,a,h'  (e'', xs'')  (stk', loc', pc', xcp')"
      and red: "?red a' xs e'' xs'' a stk pc pc' xcp xcp'" by auto
    from bisim' have "P,a∙compareAndSwap(DF, i, e),h'  (e''∙compareAndSwap(DF, i, e), xs'')  (stk', loc', pc', xcp')"
      by(rule bisim1_bisims1.bisim1CAS1)
    moreover from True have "no_call2 (a∙compareAndSwap(DF, i, e)) pc = no_call2 a pc" by(simp add: no_call2_def)
    ultimately show ?thesis using red τ by(fastforce intro: CAS1Red1 elim!: CAS_τred1r_xt1 CAS_τred1t_xt1)
  next
    case False
    with pc have pc: "pc = length (compE2 a)" by auto
    with bisim1 obtain v where a': "is_val a'  a' = Val v" 
      and stk: "stk = [v]" and xcp: "xcp = None" and call: "call1 a' = None"
      by(auto dest: bisim1_pc_length_compE2D)
    with bisim1 pc len bsok have rede1': "τred1r P t h (a', xs) (Val v, loc)"
      by(auto intro: bisim1_Val_τred1r simp add: bsok_def)
    hence "τred1r P t h (a'∙compareAndSwap(DF, i, e), xs) (Val v∙compareAndSwap(DF, i, e), loc)" by(rule CAS_τred1r_xt1)
    moreover from pc exec stk xcp
    have exec': "exec_meth_d (compP2 P) (compE2 a @ compE2 i @ compE2 e @ [CAS F D]) (compxE2 a 0 0 @ shift (length (compE2 a)) (stack_xlift (length [v]) (compxE2 i 0 0) @ shift (length (compE2 i)) (compxE2 e 0 (Suc (Suc 0))))) t h ([] @ [v], loc, length (compE2 a) + 0, None) ta h' (stk', loc', pc', xcp')"
      by(simp add: compxE2_size_convs compxE2_stack_xlift_convs exec_move_def)
    hence "exec_meth_d (compP2 P) (compE2 i @ compE2 e @ [CAS F D]) (stack_xlift (length [v]) (compxE2 i 0 0) @ shift (length (compE2 i)) (compxE2 e 0 (Suc (Suc 0)))) t h ([] @ [v], loc, 0, None) ta h' (stk', loc', pc' - length (compE2 a), xcp')"
      by(rule exec_meth_drop_xt) auto
    hence "exec_meth_d (compP2 P) (compE2 i) (stack_xlift (length [v]) (compxE2 i 0 0)) t h ([] @ [v], loc, 0, None) ta h' (stk', loc', pc' - length (compE2 a), xcp')"
      by(rule exec_meth_take_xt) simp
    with bisim2 obtain stk'' where stk': "stk' = stk'' @ [v]"
      and exec'': "exec_move_d P t i h ([], loc, 0, None) ta h' (stk'', loc', pc' - length (compE2 a), xcp')"
      unfolding exec_move_def by(blast dest: exec_meth_stk_split)
    with pc xcp have τ: "τmove2 (compP2 P) h [v] (a∙compareAndSwap(DF, i, e)) (length (compE2 a)) None = τmove2 (compP2 P) h [] i 0 None"
      using τinstr_stk_drop_exec_move[where stk="[]" and vs="[v]"]
      by(auto simp add: τmove2_iff)
    from bisim1 have "length xs = length loc" by(rule bisim1_length_xs)
    with IH2[OF exec''] len bsok obtain e'' xs''
      where bisim': "P,i,h'  (e'', xs'')  (stk'', loc', pc' - length (compE2 a), xcp')"
      and red: "?red i loc e'' xs'' i [] 0 (pc' - length (compE2 a)) None xcp'" by fastforce
    from bisim'
    have "P,a∙compareAndSwap(DF, i, e),h'  (Val v∙compareAndSwap(DF, e'', e), xs'')  (stk'' @ [v], loc', length (compE2 a) + (pc' - length (compE2 a)), xcp')"
      by(rule bisim1_bisims1.bisim1CAS2)
    moreover from red τ have "?red (Val v∙compareAndSwap(DF, i, e)) loc (Val v∙compareAndSwap(DF, e'', e)) xs'' (a∙compareAndSwap(DF, i, e)) [v] (length (compE2 a)) pc' None xcp'"
      by(fastforce intro: CAS1Red2 elim!: CAS_τred1r_xt2 CAS_τred1t_xt2 split: if_split_asm simp add: no_call2_def)
    moreover from exec' have "pc'  length (compE2 a)"
      by(rule exec_meth_drop_xt_pc) auto
    moreover have "no_call2 (a∙compareAndSwap(DF, i, e)) pc" using pc by(simp add: no_call2_def)
    ultimately show ?thesis using τ stk' pc xcp stk by(fastforce elim!: rtranclp_trans)
  qed
next
  case (bisim1CAS2 i n i' xs stk loc pc xcp a e D F v)
  note IH2 = bisim1CAS2.IH(2)
  note IH3 = bisim1CAS2.IH(6)
  note exec = ?exec (a∙compareAndSwap(DF, i, e)) (stk @ [v]) loc (length (compE2 a) + pc) xcp stk' loc' pc' xcp'
  note bisim2 = P,i,h  (i', xs)  (stk, loc, pc, xcp)
  note bisim3 = P,e,h  (e, loc)  ([], loc, 0, None)
  note len = n + max_vars (Val v∙compareAndSwap(DF, i', e))  length xs
  note bsok = ‹bsok (a∙compareAndSwap(DF, i, e)) n
  from bisim2 have pc: "pc  length (compE2 i)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 i)")
    case True
    from exec have exec': "exec_meth_d (compP2 P) (compE2 a @ compE2 i @ compE2 e @ [CAS F D]) (compxE2 a 0 0 @ shift (length (compE2 a)) (stack_xlift (length [v]) (compxE2 i 0 0) @ shift (length (compE2 i)) (compxE2 e 0 (Suc (Suc 0))))) t h (stk @ [v], loc, length (compE2 a) + pc, xcp) ta h' (stk', loc', pc', xcp')"
      by(simp add: shift_compxE2 stack_xlift_compxE2 ac_simps exec_move_def)
    hence "exec_meth_d (compP2 P) (compE2 i @ compE2 e @ [CAS F D]) (stack_xlift (length [v]) (compxE2 i 0 0) @ shift (length (compE2 i)) (compxE2 e 0 (Suc (Suc 0)))) t h (stk @ [v], loc, pc, xcp) ta h' (stk', loc', pc' - length (compE2 a), xcp')"
      by(rule exec_meth_drop_xt) auto
    hence "exec_meth_d (compP2 P) (compE2 i) (stack_xlift (length [v]) (compxE2 i 0 0)) t h (stk @ [v], loc, pc, xcp) ta h' (stk', loc', pc' - length (compE2 a), xcp')"
      using True by(rule exec_meth_take_xt)
    with bisim2 obtain stk'' where stk': "stk' = stk'' @ [v]"
      and exec'': "exec_move_d P t i h (stk, loc, pc, xcp) ta h' (stk'', loc', pc' - length (compE2 a), xcp')"
      unfolding exec_move_def by(blast dest: exec_meth_stk_split)
    with True have τ: "τmove2 (compP2 P) h (stk @ [v]) (a∙compareAndSwap(DF, i, e)) (length (compE2 a) + pc) xcp = τmove2 (compP2 P) h stk i pc xcp"
      by(auto simp add: τmove2_iff τinstr_stk_drop_exec_move)
    moreover from P,h  stk @ [v] [:≤] ST obtain ST2 where "P,h  stk [:≤] ST2" by(auto simp add: list_all2_append1)
    from IH2[OF exec'' _ _ this ‹conf_xcp' (compP2 P) h xcp] len bsok obtain e'' xs''
      where bisim': "P,i,h'  (e'', xs'')  (stk'', loc', pc' - length (compE2 a), xcp')"
      and red: "?red i' xs e'' xs'' i stk pc (pc' - length (compE2 a)) xcp xcp'" by fastforce
    from bisim'
    have "P,a∙compareAndSwap(DF, i, e),h'  (Val v∙compareAndSwap(DF, e'', e), xs'')  (stk'' @ [v], loc', length (compE2 a) + (pc' - length (compE2 a)), xcp')"
      by(rule bisim1_bisims1.bisim1CAS2)
    moreover from exec' have "pc'  length (compE2 a)"
      by(rule exec_meth_drop_xt_pc) auto
    moreover have "no_call2 i pc  no_call2 (a∙compareAndSwap(DF, i, e)) (length (compE2 a) + pc)" by(simp add: no_call2_def)
    ultimately show ?thesis using red τ stk' True
      by(fastforce intro: CAS1Red2 elim!: CAS_τred1r_xt2 CAS_τred1t_xt2 split: if_split_asm)
  next
    case False
    with pc have [simp]: "pc = length (compE2 i)" by simp
    with bisim2 obtain v2 where i': "is_val i'  i' = Val v2" 
      and stk: "stk = [v2]" and xcp: "xcp = None" and call: "call1 i' = None"
      by(auto dest: bisim1_pc_length_compE2D)
    with bisim2 pc len bsok have red: "τred1r P t h (i', xs) (Val v2, loc)"
      by(auto intro: bisim1_Val_τred1r simp add: bsok_def)
    hence "τred1r P t h (Val v∙compareAndSwap(DF, i', e ), xs) (Val v∙compareAndSwap(DF, Val v2, e), loc)" by(rule CAS_τred1r_xt2)
    moreover from pc exec stk xcp
    have exec': "exec_meth_d (compP2 P) ((compE2 a @ compE2 i) @ compE2 e @ [CAS F D]) ((compxE2 a 0 0 @ compxE2 i (length (compE2 a)) (Suc 0)) @ shift (length (compE2 a @ compE2 i)) (stack_xlift (length [v2, v]) (compxE2 e 0 0))) t h ([] @ [v2, v], loc, length (compE2 a @ compE2 i) + 0, None) ta h' (stk', loc', pc', xcp')"
      by(simp add: compxE2_size_convs compxE2_stack_xlift_convs exec_move_def)
    hence "exec_meth_d (compP2 P) (compE2 e @ [CAS F D]) (stack_xlift (length [v2, v]) (compxE2 e 0 0)) t h ([] @ [v2, v], loc, 0, None) ta h' (stk', loc', pc' - length (compE2 a @ compE2 i), xcp')"
      by(rule exec_meth_drop_xt) auto
    hence "exec_meth_d (compP2 P) (compE2 e) (stack_xlift (length [v2, v]) (compxE2 e 0 0)) t h ([] @ [v2, v], loc, 0, None) ta h' (stk', loc', pc' - length (compE2 a @ compE2 i), xcp')"
      by(rule exec_meth_take) simp
    with bisim3 obtain stk'' where stk': "stk' = stk'' @ [v2, v]"
      and exec'': "exec_move_d P t e h ([], loc, 0, None) ta h' (stk'', loc', pc' - length (compE2 a @ compE2 i), xcp')"
      unfolding exec_move_def by(blast dest: exec_meth_stk_split)
    with pc xcp have τ: "τmove2 (compP2 P) h [v2, v] (a∙compareAndSwap(DF, i, e)) (length (compE2 a) + length (compE2 i)) None = τmove2 (compP2 P) h [] e 0 None"
      using τinstr_stk_drop_exec_move[where stk="[]" and vs="[v2, v]"] by(simp add: τmove2_iff)
    from bisim2 have "length xs = length loc" by(rule bisim1_length_xs)
    with IH3[OF exec'', of "[]"] len bsok obtain e'' xs''
      where bisim': "P,e,h'  (e'', xs'')  (stk'', loc', pc' - length (compE2 a) - length (compE2 i), xcp')"
      and red: "?red e loc e'' xs'' e [] 0 (pc' - length (compE2 a) - length (compE2 i)) None xcp'"
      by auto (fastforce simp only: length_append diff_diff_left)
    from bisim'
    have "P,a∙compareAndSwap(DF, i, e),h'  (Val v∙compareAndSwap(DF, Val v2, e''), xs'')  (stk'' @ [v2, v], loc', length (compE2 a) + length (compE2 i) + (pc' - length (compE2 a) - length (compE2 i)), xcp')"
      by(rule bisim1_bisims1.bisim1CAS3)
    moreover from red τ
    have "?red (Val v∙compareAndSwap(DF, Val v2, e)) loc (Val v∙compareAndSwap(DF, Val v2, e'')) xs'' (a∙compareAndSwap(DF, i, e)) [v2, v] (length (compE2 a) + length (compE2 i)) pc' None xcp'"
      by(fastforce intro: CAS1Red3 elim!: CAS_τred1r_xt3 CAS_τred1t_xt3 split: if_split_asm simp add: no_call2_def)
    moreover from exec' have "pc'  length (compE2 a @ compE2 i)"
      by(rule exec_meth_drop_xt_pc) auto
    moreover have "no_call2 (a∙compareAndSwap(DF, i, e)) (length (compE2 a) + pc)" by(simp add: no_call2_def)
    ultimately show ?thesis using τ stk' pc xcp stk by(fastforce elim!: rtranclp_trans)
  qed
next
  case (bisim1CAS3 e n e' xs stk loc pc xcp a i D F v v')
  note IH3 = bisim1CAS3.IH(2)
  note exec = ?exec (a∙compareAndSwap(DF, i, e)) (stk @ [v', v]) loc (length (compE2 a) + length (compE2 i) + pc) xcp stk' loc' pc' xcp'
  note bisim3 = P,e,h  (e', xs)  (stk, loc, pc, xcp)
  note len = n + max_vars _  length xs
  note bsok = ‹bsok (a∙compareAndSwap(DF, i, e)) n
  from P,h  stk @ [v', v] [:≤] ST obtain T T' ST'
    where [simp]: "ST = ST' @ [T', T]"
    and wtv: "P,h  v :≤ T" and wtv': "P,h  v' :≤ T'" and ST': "P,h  stk [:≤] ST'"
    by(auto simp add: list_all2_Cons1 list_all2_append1)
  from bisim3 have pc: "pc  length (compE2 e)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e)")
    case True
    from exec have exec': "exec_meth_d (compP2 P) ((compE2 a @ compE2 i) @ compE2 e @ [CAS F D]) ((compxE2 a 0 0 @ compxE2 i (length (compE2 a)) (Suc 0)) @ shift (length (compE2 a @ compE2 i)) (stack_xlift (length [v', v]) (compxE2 e 0 0))) t h (stk @ [v', v], loc, length (compE2 a @ compE2 i) + pc, xcp) ta h' (stk', loc', pc', xcp')"
      by(simp add: shift_compxE2 stack_xlift_compxE2 exec_move_def)
    hence "exec_meth_d (compP2 P) (compE2 e @ [CAS F D]) (stack_xlift (length [v', v]) (compxE2 e 0 0)) t h (stk @ [v', v], loc, pc, xcp) ta h' (stk', loc', pc' - length (compE2 a @ compE2 i), xcp')"
      by(rule exec_meth_drop_xt) auto
    hence "exec_meth_d (compP2 P) (compE2 e) (stack_xlift (length [v', v]) (compxE2 e 0 0)) t h (stk @ [v', v], loc, pc, xcp) ta h' (stk', loc', pc' - length (compE2 a @ compE2 i), xcp')"
      using True by(rule exec_meth_take)
    with bisim3 obtain stk'' where stk': "stk' = stk'' @ [v', v]"
      and exec'': "exec_move_d P t e h (stk, loc, pc, xcp) ta h' (stk'', loc', pc' - length (compE2 a @ compE2 i), xcp')"
      unfolding exec_move_def by(blast dest: exec_meth_stk_split)
    with True have τ: "τmove2 (compP2 P) h (stk @ [v', v]) (a∙compareAndSwap(DF, i, e)) (length (compE2 a) + length (compE2 i) + pc) xcp = τmove2 (compP2 P) h stk e pc xcp"
      by(auto simp add: τmove2_iff τinstr_stk_drop_exec_move)
    moreover from IH3[OF exec'' _ _ ST' ‹conf_xcp' (compP2 P) h xcp] len bsok obtain e'' xs''
      where bisim': "P,e,h'  (e'', xs'')  (stk'', loc', pc' - length (compE2 a) - length (compE2 i), xcp')"
      and red: "?red e' xs e'' xs'' e stk pc (pc' - length (compE2 a) - length (compE2 i)) xcp xcp'"
      by auto(fastforce simp only: length_append diff_diff_left)
    from bisim'
    have "P,a∙compareAndSwap(DF, i, e),h'  (Val v∙compareAndSwap(DF, Val v', e''), xs'')  (stk'' @ [v', v], loc', length (compE2 a) + length (compE2 i) + (pc' - length (compE2 a) - length (compE2 i)), xcp')"
      by(rule bisim1_bisims1.bisim1CAS3)
    moreover from exec' have "pc'  length (compE2 a @ compE2 i)"
      by(rule exec_meth_drop_xt_pc) auto
    moreover have "no_call2 e pc  no_call2 (a∙compareAndSwap(DF, i, e)) (length (compE2 a) + length (compE2 i) + pc)"
      by(simp add: no_call2_def)
    ultimately show ?thesis using red τ stk' True
      by(fastforce intro: CAS1Red3 elim!: CAS_τred1r_xt3 CAS_τred1t_xt3 split: if_split_asm)
  next
    case False
    with pc have [simp]: "pc = length (compE2 e)" by simp
    with bisim3 obtain v2 where stk: "stk = [v2]" and xcp: "xcp = None"
      by(auto dest: bisim1_pc_length_compE2D)
    with bisim3 pc len bsok have red: "τred1r P t h (e', xs) (Val v2, loc)" 
      by(auto intro: bisim1_Val_τred1r simp add: bsok_def)
    hence "τred1r P t h (Val v∙compareAndSwap(DF, Val v', e'), xs) (Val v∙compareAndSwap(DF, Val v', Val v2), loc)" by(rule CAS_τred1r_xt3)
    moreover have τ: "¬ τmove2 (compP2 P) h [v2, v', v] (a∙compareAndSwap(DF, i, e)) (length (compE2 a) + length (compE2 i) + length (compE2 e)) None"
      by(simp add: τmove2_iff)
    moreover 
    have "ta' e''. P,a∙compareAndSwap(DF, i, e),h'  (e'',loc)  (stk', loc', pc', xcp')  True,P,t ⊢1 Val v∙compareAndSwap(DF, Val v', Val v2), (h, loc) -ta' e'',(h', loc)  ta_bisim wbisim1 (extTA2J1 P ta') ta"
    proof(cases "v = Null")
      case True with exec stk xcp show ?thesis
        by(fastforce elim!: exec_meth.cases simp add: exec_move_def intro: bisim1CASFail CAS1Null)
    next
      case False
      have "P,a∙compareAndSwap(DF, i, e),h'  (Val (Bool b), loc)  ([Bool b], loc, length (compE2 (a∙compareAndSwap(DF, i, e))), None)" for b
        by(rule bisim1Val2) simp
      with False exec stk xcp show ?thesis
        by (auto elim!: exec_meth.cases simp add: exec_move_def is_Ref_def intro: Red1CASSucceed Red1CASFail)
          (fastforce intro!: Red1CASSucceed Red1CASFail simp add: ta_bisim_def ac_simps)+
    qed
    ultimately show ?thesis using exec xcp stk by(fastforce simp add: no_call2_def)
  qed
next
  case (bisim1CASThrow1 A n a xs stk loc pc i e D F)
  note exec = ?exec (A∙compareAndSwap(DF, i, e)) stk loc pc a stk' loc' pc' xcp'
  note bisim1 = P,A,h  (Throw a, xs)  (stk, loc, pc, a)
  from bisim1 have pc: "pc < length (compE2 A)" by(auto dest: bisim1_ThrowD)
  from bisim1 have "match_ex_table (compP2 P) (cname_of h a) (0 + pc) (compxE2 A 0 0) = None"
    unfolding compP2_def by(rule bisim1_xcp_Some_not_caught)
  with exec pc have False
    by(auto elim!: exec_meth.cases simp add: match_ex_table_not_pcs_None exec_move_def)
  thus ?case ..
next
  case (bisim1CASThrow2 i n a xs stk loc pc A e D F v)
  note exec = ?exec (A∙compareAndSwap(DF, i, e)) (stk @ [v]) loc (length (compE2 A) + pc) a stk' loc' pc' xcp'
  note bisim2 = P,i,h  (Throw a, xs)  (stk, loc, pc, a)
  from bisim2 have pc: "pc < length (compE2 i)" by(auto dest: bisim1_ThrowD)
  from bisim2 have "match_ex_table (compP2 P) (cname_of h a) (length (compE2 A) + pc) (compxE2 i (length (compE2 A)) 0) = None"
    unfolding compP2_def by(rule bisim1_xcp_Some_not_caught)
  with exec pc have False
    apply(auto elim!: exec_meth.cases simp add: compxE2_stack_xlift_convs compxE2_size_convs exec_move_def)
    apply(auto simp add: match_ex_table_append_not_pcs)
    done
  thus ?case .. 
next
  case (bisim1CASThrow3 e n a xs stk loc pc A i D F v' v)
  note exec = ?exec (A∙compareAndSwap(DF, i, e)) (stk @ [v', v]) loc (length (compE2 A) + length (compE2 i) + pc) a stk' loc' pc' xcp'
  note bisim2 = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  from bisim2 have "match_ex_table (compP2 P) (cname_of h a) (length (compE2 A) + length (compE2 i) + pc) (compxE2 e (length (compE2 A) + length (compE2 i)) 0) = None"
    unfolding compP2_def by(rule bisim1_xcp_Some_not_caught)
  with exec have False
    apply(auto elim!: exec_meth.cases simp add: compxE2_stack_xlift_convs compxE2_size_convs exec_move_def)
    apply(auto dest!: match_ex_table_stack_xliftD match_ex_table_shift_pcD dest: match_ex_table_pcsD simp add: match_ex_table_append match_ex_table_shift_pc_None)
    done
  thus ?case .. 
next
  case (bisim1CASFail a n i e D F ad xs v' v v'')
  note exec = ?exec (a∙compareAndSwap(DF, i, e)) [v', v, v''] xs (length (compE2 a) + length (compE2 i) + length (compE2 e)) ad stk' loc' pc' xcp'
  hence False
    by(auto elim!: exec_meth.cases simp add: match_ex_table_append exec_move_def
            dest!: match_ex_table_shift_pcD match_ex_table_pc_length_compE2)
  thus ?case ..
next
  case (bisim1Call1 obj n obj' xs stk loc pc xcp ps M')
  note IH1 = bisim1Call1.IH(2)
  note IH2 = bisim1Call1.IH(4)
  note exec = ?exec (objM'(ps)) stk loc pc xcp stk' loc' pc' xcp'
  note bisim1 = P,obj,h  (obj', xs)  (stk, loc, pc, xcp)
  note bisim2 = P,ps,h  (ps, loc) [↔] ([], loc, 0, None)
  note len = n + max_vars (obj'M'(ps))  length xs
  note bsok = ‹bsok (objM'(ps)) n
  from bisim1 have pc: "pc  length (compE2 obj)" by(rule bisim1_pc_length_compE2)
  from bisim1 have lenxs: "length xs = length loc" by(rule bisim1_length_xs)
  show ?case
  proof(cases "pc < length (compE2 obj)")
    case True
    with exec have exec': "?exec obj stk loc pc xcp stk' loc' pc' xcp'" by(simp add: exec_move_Call1)
    from True have "τmove2 (compP2 P) h stk (objM'(ps)) pc xcp = τmove2 (compP2 P) h stk obj pc xcp" by(simp add: τmove2_iff)
    moreover from True have "no_call2 (objM'(ps)) pc = no_call2 obj pc" by(simp add: no_call2_def)
    ultimately show ?thesis 
      using IH1[OF exec' _ _ P,h  stk [:≤] ST ‹conf_xcp' (compP2 P) h xcp] bisim2 len bsok
      by(fastforce intro: bisim1_bisims1.bisim1Call1 Call1Obj elim!: Call_τred1r_obj Call_τred1t_obj)
  next
    case False
    with pc have pc: "pc = length (compE2 obj)" by auto
    with bisim1 obtain v where stk: "stk = [v]" and xcp: "xcp = None" and call: "call1 obj' = None"
      and v: "is_val obj'  obj' = Val v  xs = loc"
      by(auto dest: bisim1_pc_length_compE2D)
    with bisim1 pc len bsok have "τred1r P t h (obj', xs) (Val v, loc)" 
      by(auto intro: bisim1_Val_τred1r simp add: bsok_def)
    hence red: "τred1r P t h (obj'M'(ps), xs) (Val vM'(ps), loc)" by(rule Call_τred1r_obj)
    show ?thesis
    proof(cases ps)
      case (Cons p ps')
      from pc exec stk xcp
      have "exec_meth_d (compP2 P) (compE2 (objM'(ps))) (compxE2 (objM'(ps)) 0 0) t h ([] @ [v], loc, length (compE2 obj) + 0, None) ta h' (stk', loc', pc', xcp')"
        by(simp add: compxE2_size_convs compxE2_stack_xlift_convs exec_move_def)
      hence exec': "exec_meth_d (compP2 P) (compEs2 ps) (stack_xlift (length [v]) (compxEs2 ps 0 0)) t h ([] @ [v], loc, 0, None) ta h' (stk', loc', pc' - length (compE2 obj), xcp')"
        and pc': "pc'  length (compE2 obj)" using Cons
        by(safe dest!: Call_execParamD) simp_all
      from exec' bisim2 obtain stk'' where stk': "stk' = stk'' @ [v]"
        and exec'': "exec_moves_d P t ps h ([], loc, 0, None) ta h' (stk'', loc', pc' - length (compE2 obj), xcp')"
        unfolding exec_moves_def by -(drule (1) exec_meth_stk_splits, auto)
      with pc xcp have τ: "τmove2 (compP2 P) h [v] (objM'(ps)) (length (compE2 obj)) None = τmoves2 (compP2 P) h [] ps 0 None"
        using τinstr_stk_drop_exec_moves[where stk="[]" and vs="[v]"]
        by(auto simp add: τmove2_iff τmoves2_iff)
      from IH2[OF exec'', of "[]"] len lenxs bsok obtain es'' xs''
        where bisim': "P,ps,h'  (es'', xs'') [↔] (stk'', loc', pc' - length (compE2 obj), xcp')"
        and red': "?reds ps loc es'' xs'' ps [] 0 (pc' - length (compE2 obj)) None xcp'" by auto
      from bisim' have "P,objM'(ps),h'  (Val vM'(es''), xs'')  (stk'' @ [v], loc', length (compE2 obj) + (pc' - length (compE2 obj)), xcp')"
        by(rule bisim1CallParams)
      moreover from pc Cons have "no_call2 (objM'(ps)) pc" by(simp add: no_call2_def)
      ultimately show ?thesis using red red' τ stk' pc xcp pc' stk call
        by(fastforce elim!: rtranclp_trans Call_τred1r_param Call_τred1t_param intro: Call1Params rtranclp_tranclp_tranclp split: if_split_asm)
    next
      case [simp]: Nil
      from exec pc stk xcp
      have "v = Null  (is_Addr v  (T C' Ts' Tr' D'. typeofh v = T  class_type_of' T = C'  P  C' sees M':Ts'Tr' = Native in D'))" (is "_  ?rest")
        by(fastforce elim!: exec_meth.cases simp add: is_Ref_def exec_move_def compP2_def has_method_def split: if_split_asm)
      thus ?thesis
      proof
        assume [simp]: "v = Null"
        have "P,objM'([]),h  (THROW NullPointer, loc)  ([] @ [Null], loc, length (compE2 obj) + length (compEs2 ([]  :: 'addr expr1 list)), addr_of_sys_xcpt NullPointer)"
          by(safe intro!: bisim1CallThrow) simp_all
        moreover have "True,P,t ⊢1 nullM'(map Val []),(h, loc) -ε THROW NullPointer,(h, loc)"
          by(rule Red1CallNull)
        moreover have "τmove1 P h (Val vM'([]))" "τmove2 (compP2 P) h [Null] (objM'(ps)) (length (compE2 obj)) None"
          by(simp_all add: τmove2_iff)
        ultimately show ?thesis using exec pc stk xcp red
          by(fastforce elim!: exec_meth.cases intro: rtranclp_trans simp add: exec_move_def)
      next
        assume ?rest
        then obtain a Ta Ts' Tr' D' where [simp]: "v = Addr a"
          and Ta: "typeof_addr h a = Ta"
          and iec: "P  class_type_of Ta sees M': Ts'Tr' = Native in D'" by auto
        with exec pc stk xcp
        obtain ta' va h'' U where redex: "(ta', va, h'')  red_external_aggr (compP2 P) t a M' [] h"
          and ret: "(xcp', h', [(stk', loc', undefined, undefined, pc')]) = extRet2JVM 0 h'' [Addr a] loc undefined undefined (length (compE2 obj)) [] va"
          and wtext': "P,h  aM'([]) : U"
          and ta': "ta = extTA2JVM (compP2 P) ta'"
          by(fastforce simp add: is_Ref_def exec_move_def compP2_def external_WT'_iff exec_meth_instr)
        from Ta iec have τ: "τmove1 P h (Val vM'([]))  τmove2 (compP2 P) h [Addr a] (objM'(ps)) (length (compE2 obj)) None"
          by(auto simp add: τmove2_iff compP2_def)
        from ret have [simp]: "h'' = h'" by simp
        from wtext' have wtext'': "compP2 P,h  aM'([]) : U" by(simp add: external_WT'_iff compP2_def)
        from wf have "wf_jvm_prog (compP2 P)" by(rule wt_compP2)
        then obtain wf_md where wf': "wf_prog wf_md (compP2 P)"
          unfolding wf_jvm_prog_def by(blast dest: wt_jvm_progD)
        from tconf have tconf': "compP2 P,h  t √t" by(simp add: compP2_def tconf_def)
        from redex have redex'': "compP2 P,t  aM'([]), h -ta'→ext va, h'"
          by(simp add: WT_red_external_list_conv[OF wf' wtext'' tconf', symmetric])
        hence redex': "P,t  aM'([]), h -ta'→ext va, h'" by(simp add: compP2_def)
        with Ta iec have "True,P,t ⊢1 addr aM'(map Val []), (h, loc) -ta' extRet2J (addr aM'(map Val [])) va, (h', loc)"
          by -(rule Red1CallExternal, auto)
        moreover have "P,objM'(ps),h'  (extRet2J (addr aM'(map Val [])) va, loc)  (stk', loc', pc', xcp')"
        proof(cases va)
          case (RetVal v)
          have "P,objM'([]),h'  (Val v, loc)  ([v], loc, length (compE2 (objM'([]))), None)"
            by(rule bisim1Val2) simp
          with ret RetVal show ?thesis by simp
        next
          case (RetExc ad)
          have "P,objM'([]),h'  (Throw ad, loc)  ([] @ [v], loc, length (compE2 (obj)) + length (compEs2 ([] :: 'addr expr1 list)), ad)"
            by(rule bisim1CallThrow) simp
          with ret RetExc show ?thesis by simp
        next
          case RetStaySame
          have "P,objM'([]),h'  (addr aM'([]), loc)  ([Addr a], loc, length (compE2 obj), None)"
            by(rule bisim1_bisims1.bisim1Call1)(rule bisim1Val2, simp)
          thus ?thesis using ret RetStaySame by simp
        qed
        moreover from ‹preallocated h red_external_hext[OF redex'] have "preallocated h'" by(rule preallocated_hext) 
        from redex'' wtext'' hconf h have "hconf h'" by(rule external_call_hconf)
        with ta' redex' ‹preallocated h'
        have "ta_bisim wbisim1 (extTA2J1 P ta') ta" by(auto intro: red_external_ta_bisim21[OF wf])
        moreover have "τmove1 P h (Val vM'([]))  ta' = ε  h' = h" using redex' Ta iec
          by(fastforce dest: τexternal'_red_external_heap_unchanged τexternal'_red_external_TA_empty sees_method_fun simp add: τexternal'_def τexternal_def)
        moreover from v call
        have "call1 (obj'M'(ps))  None  Val vM'(ps) = obj'M'(ps)  loc = xs"
          by(auto split: if_split_asm)
        ultimately show ?thesis using red τ pc xcp stk Ta call iec
          apply(auto simp del: call1.simps calls1.simps)
          apply(rule exI conjI|assumption|erule rtranclp.rtrancl_into_rtrancl rtranclp_into_tranclp1|drule (1) sees_method_fun|clarsimp)+
          done
      qed
    qed
  qed
next
  case (bisim1CallParams ps n ps' xs stk loc pc xcp obj M' v)
  note bisim2 = P,ps,h  (ps', xs) [↔] (stk, loc, pc, xcp)
  note bisim1 = P,obj,h  (obj, xs)  ([], xs, 0, None)
  note IH2 = bisim1CallParams.IH(2)
  note exec = ‹exec_move_d P t (objM'(ps)) h (stk @ [v], loc, length (compE2 obj) + pc, xcp) ta h' (stk', loc', pc', xcp')
  note len = n + max_vars (Val vM'(ps'))  length xs
  note bsok = ‹bsok (objM'(ps)) n
  from P,h  stk @ [v] [:≤] ST obtain T ST' where ST': "P,h  stk [:≤] ST'" and T: "typeofh v = T"
    by(auto simp add: list_all2_Cons1 list_all2_append1 conf_def)
  from bisim2 have pc: "pc  length (compEs2 ps)" by(rule bisims1_pc_length_compEs2)
  show ?case
  proof(cases "pc < length (compEs2 ps)")
    case True
    from exec have "exec_meth_d (compP2 P) (compE2 (objM'(ps))) (compxE2 (objM'(ps)) 0 0) t h (stk @ [v], loc, length (compE2 obj) + pc, xcp) ta h' (stk', loc', pc', xcp')"
      by(simp add: exec_move_def)
    with True have exec': "exec_meth_d (compP2 P) (compEs2 ps) (stack_xlift (length [v]) (compxEs2 ps 0 0)) t h (stk @ [v], loc, pc, xcp) ta h' (stk', loc', pc' - length (compE2 obj), xcp')"
      and pc': "pc'  length (compE2 obj)" by(safe dest!: Call_execParamD)
    from exec' bisim2 obtain stk'' where stk': "stk' = stk'' @ [v]"
      and exec'': "exec_moves_d P t ps h (stk, loc, pc, xcp) ta h' (stk'', loc', pc' - length (compE2 obj), xcp')"
      by(unfold exec_moves_def)(drule (1) exec_meth_stk_splits, auto)
    with True have τ: "τmove2 (compP2 P) h (stk @ [v]) (objM'(ps)) (length (compE2 obj) + pc) xcp = τmoves2 (compP2 P) h stk ps pc xcp"
      by(auto simp add: τmove2_iff τmoves2_iff τinstr_stk_drop_exec_moves)
    from IH2[OF exec'' _ _ ST' ‹conf_xcp' (compP2 P) h xcp] len bsok obtain es'' xs''
      where bisim': "P,ps,h'  (es'', xs'') [↔] (stk'', loc', pc' - length (compE2 obj), xcp')"
      and red': "?reds ps' xs es'' xs'' ps stk pc (pc' - length (compE2 obj)) xcp xcp'" by auto
    from bisim' have "P,objM'(ps),h'  (Val vM'(es''), xs'')  (stk'' @ [v], loc', length (compE2 obj) + (pc' - length (compE2 obj)), xcp')"
      by(rule bisim1_bisims1.bisim1CallParams)
    moreover from True have "no_call2 (objM'(ps)) (length (compE2 obj) + pc) = no_calls2 ps pc"
      by(simp add: no_calls2_def no_call2_def)
    moreover have "calls1 ps' = None  call1 (Val vM'(ps')) = None  is_vals ps'" by simp
    ultimately show ?thesis using red' τ stk' pc pc'
      by(fastforce intro: Call1Params elim!: Call_τred1r_param Call_τred1t_param split: if_split_asm simp add: is_vals_conv)
  next
    case False
    with pc have [simp]: "pc = length (compEs2 ps)" by simp
    with bisim2 obtain vs where [simp]: "stk = rev vs" "xcp = None"
      and lenvs: "length vs = length ps" and vs: "is_vals ps'  ps' = map Val vs  xs = loc"
      and call: "calls1 ps' = None"
      by(auto dest: bisims1_pc_length_compEs2D)
    with bisim2 len bsok have reds: "τreds1r P t h (ps', xs) (map Val vs, loc)"
      by(auto intro: bisims1_Val_τReds1r simp add: bsok_def)
    from exec T lenvs 
    have "v = Null  (is_Addr v  (T C' Ts' Tr' D'. typeofh v = T  class_type_of' T = C'  P  C' sees M':Ts'Tr' = Native in D'))" (is "_  ?rest")
      by(fastforce elim!: exec_meth.cases simp add: is_Ref_def exec_move_def compP2_def has_method_def split: if_split_asm)
    thus ?thesis
    proof
      assume [simp]: "v = Null"
      hence τ: "τmove1 P h (Val vM'(map Val vs))"
        "τmove2 (compP2 P) h (stk @ [v]) (objM'(ps)) (length (compE2 obj) + length (compEs2 ps)) None"
        using lenvs by(auto simp add: τmove2_iff)
      from lenvs
      have "P,objM'(ps),h  (THROW NullPointer, loc)  (rev vs @ [Null], loc, length (compE2 obj) + length (compEs2 ps), addr_of_sys_xcpt NullPointer)"
        by(safe intro!: bisim1CallThrow) simp
      moreover have "True,P,t ⊢1 nullM'(map Val vs),(h, loc) -ε THROW NullPointer,(h, loc)"
        by(rule Red1CallNull)
      ultimately show ?thesis using exec pc τ lenvs reds
        apply(auto elim!: exec_meth.cases simp add: exec_move_def) 
        apply(rule exI conjI|assumption)+
        apply(rule rtranclp.rtrancl_into_rtrancl)
        apply(erule Call_τred1r_param)
        by auto
    next
      assume ?rest
      then obtain a Ta C' Ts' Tr' D' where [simp]: "v = Addr a"
        and Ta: "typeof_addr h a = Ta"
        and iec: "P  class_type_of Ta sees M': Ts'Tr' = Native in D'" by auto
      with exec pc lenvs
      obtain ta' va h'' U Ts Ts' where redex: "(ta', va, h'')  red_external_aggr (compP2 P) t a M' vs h"
        and ret: "(xcp', h', [(stk', loc', undefined, undefined, pc')]) = extRet2JVM (length vs) h'' (rev vs @ [Addr a]) loc undefined undefined (length (compE2 obj) + length (compEs2 ps)) [] va"
        and wtext': "P,h  aM'(vs) : U"
        and Ts: "map typeofh vs = map Some Ts"
        and ta': "ta = extTA2JVM (compP2 P) ta'"
        by(fastforce simp add: is_Ref_def exec_move_def compP2_def external_WT'_iff exec_meth_instr confs_conv_map)
      have τ: "τmove1 P h (Val vM'(map Val vs))  τmove2 (compP2 P) h (stk @ [v]) (objM'(ps)) (length (compE2 obj) + length (compEs2 ps)) None"
        using Ta iec lenvs
        by(auto simp add: τmove2_iff map_eq_append_conv compP2_def)
      from ret have [simp]: "h'' = h'" by simp
      from wtext' have wtext'': "compP2 P,h  aM'(vs) : U" by(simp add: compP2_def external_WT'_iff)
      from wf have "wf_jvm_prog (compP2 P)" by(rule wt_compP2)
      then obtain wf_md where wf': "wf_prog wf_md (compP2 P)"
        unfolding wf_jvm_prog_def by(blast dest: wt_jvm_progD)
      from tconf have tconf': "compP2 P,h  t √t" by(simp add: compP2_def tconf_def)
      from redex have redex'': "compP2 P,t  aM'(vs), h -ta'→ext va, h'"
        by(simp add: WT_red_external_list_conv[OF wf' wtext'' tconf', symmetric])
      hence redex': "P,t  aM'(vs), h -ta'→ext va, h'" by(simp add: compP2_def)
      with Ta iec have "True,P,t ⊢1 addr aM'(map Val vs), (h, loc) -ta' extRet2J (addr aM'(map Val vs)) va, (h', loc)"
        by -(rule Red1CallExternal, auto)
      moreover have "P,objM'(ps),h'  (extRet2J (addr aM'(map Val vs)) va, loc)  (stk', loc', pc', xcp')"
      proof(cases va)
        case (RetVal v)
        have "P,objM'(ps),h'  (Val v, loc)  ([v], loc, length (compE2 (objM'(ps))), None)"
          by(rule bisim1Val2)(simp)
        with ret RetVal show ?thesis by simp
      next
        case (RetExc ad)
        from lenvs have "length ps = length (rev vs)" by simp
        hence "P,objM'(ps),h'  (Throw ad, loc)  (rev vs @ [v], loc, length (compE2 (obj)) + length (compEs2 ps), ad)"
          by(rule bisim1CallThrow)
        with ret RetExc show ?thesis by simp
      next
        case RetStaySame
        from lenvs have "length ps = length vs" by simp
        from bisims1_map_Val_append[OF bisims1Nil this, of P h' loc]
        have "P,ps,h'  (map Val vs, loc) [↔] (rev vs, loc, length (compEs2 ps), None)" by simp
        hence "P,objM'(ps),h'  (addr aM'(map Val vs), loc)  (rev vs @ [Addr a], loc, length (compE2 obj) + length (compEs2 ps), None)"
          by(rule bisim1_bisims1.bisim1CallParams)
        thus ?thesis using ret RetStaySame by simp
      qed
      moreover from ‹preallocated h red_external_hext[OF redex'] have "preallocated h'" by(rule preallocated_hext) 
      from redex'' wtext'' hconf h have "hconf h'" by(rule external_call_hconf)
      with ta' redex' ‹preallocated h'
      have "ta_bisim wbisim1 (extTA2J1 P ta') ta" by(auto intro: red_external_ta_bisim21[OF wf])
      moreover have "τmove1 P h (Val vM'(map Val vs))  ta' = ε  h' = h"
        using Ta iec redex'
        by(fastforce dest: τexternal'_red_external_heap_unchanged τexternal'_red_external_TA_empty sees_method_fun simp add: τexternal'_def τexternal_def map_eq_append_conv)
      moreover from vs call have "call1 (Val vM'(ps'))  None  ps' = map Val vs  loc = xs"
          by(auto split: if_split_asm simp add: is_vals_conv)
      ultimately show ?thesis using reds τ pc Ta call
        apply(auto simp del: split_paired_Ex call1.simps calls1.simps split: if_split_asm simp add: map_eq_append_conv)
        apply(auto 4 4 simp del: split_paired_Ex call1.simps calls1.simps intro: rtranclp.rtrancl_into_rtrancl[OF Call_τred1r_param] rtranclp_into_tranclp1[OF Call_τred1r_param])[3]
        apply((assumption|rule exI conjI|erule Call_τred1r_param|simp add: map_eq_append_conv)+)
        done
    qed
  qed
next
  case (bisim1CallThrowObj obj n a xs stk loc pc ps M')
  note exec = ?exec (objM'(ps)) stk loc pc a stk' loc' pc' xcp'
  note bisim1 = P,obj,h  (Throw a, xs)  (stk, loc, pc, a)
  from bisim1 have pc: "pc < length (compE2 obj)" by(auto dest: bisim1_ThrowD)
  from bisim1 have "match_ex_table (compP2 P) (cname_of h a) (0 + pc) (compxE2 obj 0 0) = None"
    unfolding compP2_def by(rule  bisim1_xcp_Some_not_caught)
  with exec pc have False
    by(auto elim!: exec_meth.cases simp add: exec_move_def match_ex_table_not_pcs_None)
  thus ?case ..
next
  case (bisim1CallThrowParams ps n vs a ps' xs stk loc pc obj M' v)
  note exec = ?exec (objM'(ps)) (stk @ [v]) loc (length (compE2 obj) + pc) a stk' loc' pc' xcp'
  note bisim2 = P,ps,h  (map Val vs @ Throw a # ps', xs) [↔] (stk, loc, pc, a)
  from bisim2 have pc: "pc < length (compEs2 ps)" by(auto dest: bisims1_ThrowD)
  from bisim2 have "match_ex_table (compP2 P) (cname_of h a) (0 + pc) (compxEs2 ps 0 0) = None"
    unfolding compP2_def by(rule bisims1_xcp_Some_not_caught)
  with exec pc have False
    apply(auto elim!: exec_meth.cases simp add: compxEs2_size_convs compxEs2_stack_xlift_convs exec_move_def)
    apply(auto simp add: match_ex_table_append dest!: match_ex_table_shift_pcD match_ex_table_stack_xliftD match_ex_table_pc_length_compE2)
    done
  thus ?case ..
next
  case (bisim1CallThrow ps vs obj n M' a xs v)
  note lenvs = ‹length ps = length vs
  note exec = ?exec (objM'(ps)) (vs @ [v]) xs (length (compE2 obj) + length (compEs2 ps)) a stk' loc' pc' xcp'
  with lenvs have False
    by(auto elim!: exec_meth.cases simp add: match_ex_table_append_not_pcs exec_move_def dest!: match_ex_table_pc_length_compEs2)
  thus ?case ..
next
  case (bisim1BlockSome1 e n V Ty v xs)
  have "τmove2 (compP2 P) h [] {V:Ty=v; e} 0 None" by(simp add: τmove2_iff)
  with ?exec {V:Ty=v; e} [] xs 0 None stk' loc' pc' xcp' P,e,h  (e, xs)  ([], xs, 0, None)
  show ?case by(fastforce elim!: exec_meth.cases intro: bisim1BlockSome2 simp add: exec_move_def)
next
  case (bisim1BlockSome2 e n V Ty v xs)
  have "τmove2 (compP2 P) h [v] {V:Ty=v; e} (Suc 0) None" by(simp add: τmove2_iff)
  with ?exec {V:Ty=v; e} [v] xs (Suc 0) None stk' loc' pc' xcp' P,e,h  (e, xs)  ([], xs, 0, None)
  show ?case by(fastforce intro: r_into_rtranclp Block1Some bisim1BlockSome4[OF bisim1_refl] simp add: exec_move_def
                         elim!: exec_meth.cases)
next
  case (bisim1BlockSome4 e n  e' xs stk loc pc xcp V Ty v)
  note IH = bisim1BlockSome4.IH(2)
  note exec = ?exec {V:Ty=v; e} stk loc (Suc (Suc pc)) xcp stk' loc' pc' xcp'
  note bisim = P,e,h  (e', xs)  (stk, loc, pc, xcp)
  note bsok = ‹bsok {V:Ty=v; e} n
  with n + max_vars {V:Ty=None; e'}  length xs
  have V: "V < length xs" and len: "Suc n + max_vars e'  length xs" and [simp]: "n = V" by simp_all
  let ?pre = "[Push v, Store V]"
  from exec have exec': "exec_meth_d (compP2 P) (?pre @ compE2 e) (shift (length ?pre) (compxE2 e 0 0)) t h (stk, loc, length ?pre + pc, xcp) ta h' (stk', loc', pc', xcp')"
    by(simp add: compxE2_size_convs exec_move_def)
  hence pc': "pc'  length ?pre"
    by(rule exec_meth_drop_pc) auto
  hence pc'': "Suc (Suc (pc' - Suc (Suc 0))) = pc'" by simp
  moreover from exec' have "exec_move_d P t e h (stk, loc, pc, xcp) ta h' (stk', loc', pc' - length ?pre, xcp')"
    unfolding exec_move_def by(rule exec_meth_drop) auto
  from IH[OF this len _ P,h  stk [:≤] ST ‹conf_xcp' (compP2 P) h xcp] bsok obtain e'' xs''
    where bisim': "P,e,h'  (e'', xs'')  (stk', loc', pc' - length ?pre, xcp')"
    and red': "?red e' xs e'' xs'' e stk pc (pc' - length ?pre) xcp xcp'" by auto
  from bisim' have "P,{V:Ty=v; e},h'  ({V:Ty=None; e''}, xs'')  (stk', loc', Suc (Suc (pc' - length ?pre)), xcp')"
    by(rule bisim1_bisims1.bisim1BlockSome4)
  moreover from pc' pc'' have "τmove2 (compP2 P) h stk {V:Ty=v; e} (Suc (Suc pc)) xcp = τmove2 (compP2 P) h stk e pc xcp" by(simp add: τmove2_iff)
  moreover from red' have "length xs'' = length xs"
    by(auto split: if_split_asm dest!: τred1r_preserves_len τred1t_preserves_len red1_preserves_len)
  ultimately show ?case using red' pc'' V
    by(fastforce elim!: Block_None_τred1r_xt Block_None_τred1t_xt intro: Block1Red split: if_split_asm simp add: no_call2_def)
next
  case (bisim1BlockThrowSome e n a xs stk loc pc V Ty v)
  note exec = ?exec {V:Ty=v; e} stk loc (Suc (Suc pc)) a stk' loc' pc' xcp'
  note bisim = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  from bisim have pc: "pc < length (compE2 e)" by(auto dest: bisim1_ThrowD)
  from bisim have "match_ex_table (compP2 P) (cname_of h a) (0 + pc) (compxE2 e 0 0) = None"
    unfolding compP2_def by(rule  bisim1_xcp_Some_not_caught)
  with exec pc have False 
    apply(auto elim!: exec_meth.cases simp add: match_ex_table_not_pcs_None exec_move_def)
    apply(auto simp only: compxE2_size_convs dest!: match_ex_table_shift_pcD)
    apply simp
    done
  thus ?case ..
next
  case (bisim1BlockNone e n e' xs stk loc pc xcp V Ty)
  note IH = bisim1BlockNone.IH(2)
  note exec = ?exec {V:Ty=None; e} stk loc pc xcp stk' loc' pc' xcp'
  note bisim = P,e,h  (e', xs)  (stk, loc, pc, xcp)
  note bsok = ‹bsok {V:Ty=None; e} n
  with n + max_vars {V:Ty=None; e'}  length xs
  have V: "V < length xs" and len: "Suc n + max_vars e'  length xs" by simp_all
  have "τmove2 (compP2 P) h stk {V:Ty=None; e} pc xcp = τmove2 (compP2 P) h stk e pc xcp" by(simp add: τmove2_iff)
  moreover
  from exec have "?exec e stk loc pc xcp stk' loc' pc' xcp'" by(simp add: exec_move_BlockNone)
  from IH[OF this len _ P,h  stk [:≤] ST ‹conf_xcp' (compP2 P) h xcp] bsok obtain e'' xs''
    where bisim': "P,e,h'  (e'', xs'')  (stk', loc', pc', xcp')"
    and red': "?red e' xs e'' xs'' e stk pc pc' xcp xcp'" by auto
  from bisim' have "P,{V:Ty=None; e},h'  ({V:Ty=None; e''}, xs'')  (stk', loc', pc', xcp')"
    by(rule bisim1_bisims1.bisim1BlockNone)
  ultimately show ?case using V red' 
    by(fastforce elim!: Block1Red Block_None_τred1r_xt Block_None_τred1t_xt simp add: no_call2_def)
next
  case (bisim1BlockThrowNone e n a xs stk loc pc V Ty)
  note exec = ?exec {V:Ty=None; e} stk loc pc a stk' loc' pc' xcp'
  note bisim = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  from bisim have pc: "pc < length (compE2 e)" by(auto dest: bisim1_ThrowD)
  from bisim have "match_ex_table (compP2 P) (cname_of h a) (0 + pc) (compxE2 e 0 0) = None"
    unfolding compP2_def by(rule  bisim1_xcp_Some_not_caught)
  with exec pc have False by(auto elim!: exec_meth.cases simp add: exec_move_def)
  thus ?case ..
next
  case (bisim1Sync1 e1 n e' xs stk loc pc xcp e2 V)
  note IH = bisim1Sync1.IH(2)
  note exec = ?exec (syncV (e1) e2) stk loc pc xcp stk' loc' pc' xcp'
  note bisim = P,e1,h  (e', xs)  (stk, loc, pc, xcp)
  note bisim2 = P,e2,h  (e2, xs)  ([], xs, 0, None)
  note len = n + max_vars (syncV (e') e2)  length xs
  note bsok = ‹bsok (syncV (e1) e2) n
  from bisim have pc: "pc  length (compE2 e1)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e1)")
    case True
    with exec have exec': "?exec e1 stk loc pc xcp stk' loc' pc' xcp'" by(simp add: exec_move_Sync1)
    from True have "τmove2 (compP2 P) h stk (syncV (e1) e2) pc xcp = τmove2 (compP2 P) h stk e1 pc xcp" by(simp add: τmove2_iff)
    with IH[OF exec' _ _ P,h  stk [:≤] ST ‹conf_xcp' (compP2 P) h xcp] len bisim2 bsok show ?thesis
      by(fastforce intro: bisim1_bisims1.bisim1Sync1 Synchronized1Red1 elim!: Sync_τred1r_xt Sync_τred1t_xt simp add: no_call2_def)
  next
    case False
    with pc have [simp]: "pc = length (compE2 e1)" by simp
    with bisim obtain v where stk: "stk = [v]" and xcp: "xcp = None"
      by(auto dest: bisim1_pc_length_compE2D)
    with bisim pc len bsok have red: "τred1r P t h (e', xs) (Val v, loc)"
      by(auto intro: bisim1_Val_τred1r simp add: bsok_def)
    hence "τred1r P t h (syncV (e') e2, xs) (syncV (Val v) e2, loc)" by(rule Sync_τred1r_xt)
    moreover have τ: "τmove2 (compP2 P) h [v] (syncV (e1) e2) pc None" by(simp add: τmove2_iff)
    moreover
    have "P,(syncV (e1) e2),h  ((syncV (Val v) e2), loc)  ([v, v], loc, Suc (length (compE2 e1)), None)"
      by(rule bisim1Sync2)
    ultimately show ?thesis using exec stk xcp
      by(fastforce elim!: exec_meth.cases simp add: exec_move_def)
  qed
next
  case (bisim1Sync2 e1 n e2 V v xs)
  note exec = ?exec (syncV (e1) e2) [v, v] xs (Suc (length (compE2 e1))) None stk' loc' pc' xcp'
  note bisim = P,e1,h  (e1, xs)  ([], xs, 0, None)
  note bisim2 = P,e2,h  (e2, xs)  ([], xs, 0, None)
  have "τmove2 (compP2 P) h [v, v] (syncV (e1) e2) (Suc (length (compE2 e1))) None" by(rule τmove2Sync3)
  thus ?case using exec 
    by(fastforce elim!: exec_meth.cases intro: bisim1Sync3 simp add: exec_move_def)
next
  case (bisim1Sync3 e1 n e2 V v xs)
  note exec = ?exec (syncV (e1) e2) [v] (xs[V := v]) (Suc (Suc (length (compE2 e1)))) None stk' loc' pc' xcp'
  note bisim = P,e1,h  (e1, xs)  ([], xs, 0, None)
  note bisim2 = xs. P,e2,h  (e2, xs)  ([], xs, 0, None)
  note len = n + max_vars (syncV (Val v) e2)  length xs
  note bsok = ‹bsok (syncV (e1) e2) n
  with len have V: "V < length xs" by simp
  have τ: "¬ τmove2 (compP2 P) h [v] (syncV (e1) e2) (Suc (Suc (length (compE2 e1)))) None" by(simp add: τmove2_iff)
  from exec have "(a. v = Addr a  stk' = []  loc' = xs[V := v]  ta = Locka, SyncLock a  xcp' = None  pc' = Suc (Suc (Suc (length (compE2 e1)))))  (v = Null  stk' = [v]  loc' = xs[V := v]  ta = ε  xcp' = addr_of_sys_xcpt NullPointer  pc' = Suc (Suc (length (compE2 e1))))" (is "?c1  ?c2")
    by(fastforce elim!: exec_meth.cases simp add: is_Ref_def expand_finfun_eq fun_eq_iff finfun_upd_apply exec_move_def)
  thus ?case
  proof
    assume ?c1
    then obtain a where [simp]: "v = Addr a" "stk' = []" "loc' = xs[V := v]" "ta = Locka, SyncLock a"
      "xcp' = None" "pc' = Suc (Suc (Suc (length (compE2 e1))))" by blast
    have "True,P,t ⊢1 syncV (addr a) e2, (h, xs) -Locka, SyncLock a insyncV (a) e2,(h, xs[V := Addr a])"
      using V by(rule Lock1Synchronized)
    moreover from bisim2 have "P,syncV (e1) e2,h  (insyncV (a) e2, xs[V := Addr a])  ([], xs[V := Addr a], Suc (Suc (Suc (length (compE2 e1)))), None)"
      by(auto intro: bisim1Sync4[where pc = 0, simplified])
    ultimately show ?case using exec τ
      by(fastforce elim!: exec_meth.cases split: if_split_asm simp add: is_Ref_def exec_move_def ta_bisim_def ta_upd_simps)
  next
    assume ?c2
    hence [simp]: "v = Null" "stk' = [v]" "loc' = xs[V := v]" "ta = ε" "xcp' = addr_of_sys_xcpt NullPointer"
      "pc' = Suc (Suc (length (compE2 e1)))" by simp_all
    from V have "True,P,t ⊢1 syncV (null) e2, (h, xs) -ε THROW NullPointer,(h, xs[V := Null])"
      by(rule Synchronized1Null)
    moreover 
    have "P,syncV (e1) e2,h  (THROW NullPointer, xs[V := Null])  ([Null], xs[V := Null], Suc (Suc (length (compE2 e1))), addr_of_sys_xcpt NullPointer)"
      by(rule bisim1Sync11)
    ultimately show ?case using exec τ
      by(fastforce elim!: exec_meth.cases split: if_split_asm simp add: is_Ref_def exec_move_def)
  qed
next
  case (bisim1Sync4 e2 n e' xs stk loc pc xcp e1 V a)
  note IH = bisim1Sync4.IH(2)
  note exec = ?exec (syncV (e1) e2) stk loc (Suc (Suc (Suc (length (compE2 e1) + pc)))) xcp stk' loc' pc' xcp'
  note bisim1 = P,e1,h  (e1, xs)  ([], xs, 0, None)
  note bisim2 = P,e2,h  (e', xs)  (stk, loc, pc, xcp)
  note len = n + max_vars (insyncV (a) e')  length xs
  note bsok = ‹bsok (syncV (e1) e2) n
  with len have V: "V < length xs" and len': "Suc n + max_vars e'  length xs" by simp_all
  from bisim2 have pc: "pc  length (compE2 e2)" by(rule bisim1_pc_length_compE2)
  let ?pre = "compE2 e1 @ [Dup, Store V, MEnter]"
  let ?post = "[Load V, MExit, Goto 4, Load V, MExit, ThrowExc]"
  from exec have exec': "exec_meth_d (compP2 P) (?pre @ compE2 e2 @ ?post)
    (compxE2 e1 0 0 @ shift (length ?pre) (compxE2 e2 0 0 @ [(0, length (compE2 e2), None, 3 + length (compE2 e2), 0)])) t
    h (stk, loc, length ?pre + pc, xcp) ta h' (stk', loc', pc', xcp')"
    by(simp add: ac_simps eval_nat_numeral shift_compxE2 exec_move_def)
  hence pc': "pc'  length ?pre"
    by(rule exec_meth_drop_xt_pc[where n'=1]) auto
  from exec' have exec'': "exec_meth_d (compP2 P) (compE2 e2 @ ?post) 
    (compxE2 e2 0 0 @ [(0, length (compE2 e2), None, 3 + length (compE2 e2), 0)]) t
    h (stk, loc, pc, xcp) ta h' (stk', loc', pc' - length ?pre, xcp')"
    by(rule exec_meth_drop_xt[where n=1]) auto
  show ?case
  proof(cases "pc < length (compE2 e2)")
    case True
    note pc = True
    hence τ: "τmove2 (compP2 P) h stk (syncV (e1) e2) (Suc (Suc (Suc (length (compE2 e1) + pc)))) xcp = τmove2 (compP2 P) h stk e2 pc xcp"
      by(simp add: τmove2_iff)
    show ?thesis
    proof(cases "xcp = None  (a'. xcp = a'  match_ex_table (compP2 P) (cname_of h a') pc (compxE2 e2 0 0)  None)")
      case False
      then obtain a' where Some: "xcp = a'" 
        and True: "match_ex_table (compP2 P) (cname_of h a') pc (compxE2 e2 0 0) = None" by(auto simp del: not_None_eq)
      from Some ‹conf_xcp' (compP2 P) h xcp obtain D
        where ha': "typeof_addr h a' = Class_type D" and subcls: "P  D * Throwable" by(auto simp add: compP2_def)
      from ha' subcls bisim2 True bsok have "τred1r P t h (e', xs) (Throw a', loc)"
        using len' unfolding Some compP2_def by(auto dest!: bisim1_xcp_τRed simp add: bsok_def)
      moreover from pc have "τmove2 (compP2 P) h stk (syncV (e1) e2) (Suc (Suc (Suc (pc + length (compE2 e1))))) a'"
        by(auto intro: τmove2xcp)
      moreover 
      have "P, syncV (e1) e2, h  (insyncV (a) Throw a', loc)  ([Addr a'], loc, 6 + length (compE2 e1) + length (compE2 e2), None)"
        by(rule bisim1Sync7)
      ultimately show ?thesis using exec True pc Some ha' subcls
        apply(auto elim!: exec_meth.cases simp add: ac_simps eval_nat_numeral match_ex_table_append matches_ex_entry_def compP2_def exec_move_def)

        apply(simp_all only: compxE2_size_convs, auto dest: match_ex_table_shift_pcD match_ex_table_pc_length_compE2)
        apply(fastforce elim!: InSync_τred1r_xt)
        done
    next
      case True 
      with exec'' pc have "exec_meth_d (compP2 P) (compE2 e2 @ ?post) (compxE2 e2 0 0) t
        h (stk, loc, pc, xcp) ta h' (stk', loc', pc' - length ?pre, xcp')"
        by(auto elim!: exec_meth.cases intro: exec_meth.intros simp add: match_ex_table_append exec_move_def)
      hence "exec_move_d P t e2 h (stk, loc, pc, xcp) ta h' (stk', loc', pc' - length ?pre, xcp')"
        using pc unfolding exec_move_def by(rule exec_meth_take)
      from IH[OF this len' _ P,h  stk [:≤] ST ‹conf_xcp' (compP2 P) h xcp] bsok obtain e'' xs''
        where bisim': "P,e2,h'  (e'', xs'')  (stk', loc', pc' - length ?pre, xcp')"
        and red': "?red e' xs e'' xs'' e2 stk pc (pc' - length ?pre) xcp xcp'" by auto
      from bisim'
      have "P,syncV (e1) e2, h'  (insyncV (a) e'', xs'')  (stk', loc', Suc (Suc (Suc (length (compE2 e1) + (pc' - length ?pre)))), xcp')"
        by(rule bisim1_bisims1.bisim1Sync4)
      moreover from pc' have "Suc (Suc (Suc (length (compE2 e1) + (pc' - Suc (Suc (Suc (length (compE2 e1)))))))) = pc'"
        "Suc (Suc (Suc (pc' - Suc (Suc (Suc 0))))) = pc'"
        by simp_all
      ultimately show ?thesis using red' τ
        by(fastforce intro: Synchronized1Red2 simp add: eval_nat_numeral no_call2_def elim!: InSync_τred1r_xt InSync_τred1t_xt split: if_split_asm)
    qed
  next
    case False
    with pc have [simp]: "pc = length (compE2 e2)" by simp
    with bisim2 obtain v where [simp]: "stk = [v]" "xcp = None" by(auto dest: bisim1_pc_length_compE2D)
    have "τmove2 (compP2 P) h [v] (syncV (e1) e2) (Suc (Suc (Suc (length (compE2 e1) + length (compE2 e2))))) None" by(simp add: τmove2_iff)
    moreover from bisim2 pc len bsok have red: "τred1r P t h (e', xs) (Val v, loc)"
      by(auto intro!: bisim1_Val_τred1r simp add: bsok_def)
    hence "τred1r P t h (insyncV (a) e', xs) (insyncV (a) (Val v), loc)" by(rule InSync_τred1r_xt)
    moreover
    have "P,syncV (e1) e2,h  (insyncV (a) (Val v), loc)  ([loc ! V, v], loc, 4 + length (compE2 e1) + length (compE2 e2), None)"
      by(rule bisim1Sync5)
    ultimately show ?thesis using exec
      by(auto elim!: exec_meth.cases simp add: eval_nat_numeral exec_move_def) blast
  qed
next
  case (bisim1Sync5 e1 n e2 V a v xs)
  note bisim1 = P,e1,h  (e1, xs)  ([], xs, 0, None)
  note bisim2 = P,e2,h  (e2, xs)  ([], xs, 0, None)
  note exec = ?exec (syncV (e1) e2) [xs ! V, v] xs (4 + length (compE2 e1) + length (compE2 e2)) None stk' loc' pc' xcp'
  from n + max_vars (insyncV (a) Val v)  length xs ‹bsok (syncV (e1) e2) n have V: "V < length xs" by simp
  have τ: "¬ τmove2 (compP2 P) h [xs ! V, v] (syncV (e1) e2) (4 + length (compE2 e1) + length (compE2 e2)) None"
    by(simp add: τmove2_iff)
  have τ': "¬ τmove1 P h (insyncV (a) Val v)" by auto
  from exec have "(a'. xs ! V = Addr a')  xs ! V = Null" (is "?c1  ?c2")
    by(auto elim!: exec_meth.cases simp add: split_beta is_Ref_def exec_move_def split: if_split_asm)
  thus ?case
  proof
    assume ?c1
    then obtain a' where xsV [simp]: "xs ! V = Addr a'" ..
    have "P,syncV (e1) e2,h  (Val v, xs)  ([v], xs, 5 + length (compE2 e1) + length (compE2 e2), None)"
      "P,syncV (e1) e2,h  (THROW IllegalMonitorState,xs)  ([Addr a', v],xs,4 + length (compE2 e1) + length (compE2 e2),addr_of_sys_xcpt IllegalMonitorState)"
      by(rule bisim1Sync6, rule bisim1Sync12)
    moreover from xsV V have "True,P,t ⊢1 insyncV (a) Val v, (h, xs) -Unlocka', SyncUnlock a' Val v,(h, xs)"
      by(rule Unlock1Synchronized)
    moreover from xsV V have "True,P,t ⊢1 insyncV (a) Val v, (h, xs) -UnlockFaila' THROW IllegalMonitorState,(h, xs)"
      by(rule Unlock1SynchronizedFail[OF TrueI])
    ultimately show ?case using τ τ' exec
      by (fastforce elim!: exec_meth.cases simp add: is_Ref_def ta_bisim_def exec_move_def ac_simps ta_upd_simps
        simp del: conj.left_commute)
  next
    assume xsV: "xs ! V = Null"
    have "P,syncV (e1) e2,h  (THROW NullPointer,xs)  ([Null, v],xs,4 + length (compE2 e1) + length (compE2 e2),addr_of_sys_xcpt NullPointer)"
      by(rule bisim1Sync12)
    thus ?case using τ τ' exec xsV V
      by (fastforce elim!: exec_meth.cases intro: Unlock1SynchronizedNull simp add: is_Ref_def ta_bisim_def ac_simps exec_move_def
        simp del: conj.left_commute)
  qed
next
  case (bisim1Sync6 e1 n e2 V v x)
  note bisim1 = P,e1,h  (e1, xs)  ([], xs, 0, None)
  note bisim2 = P,e2,h  (e2, xs)  ([], xs, 0, None)
  note exec = ?exec (syncV (e1) e2) [v] x (5 + length (compE2 e1) + length (compE2 e2)) None stk' loc' pc' xcp'
  have "τmove2 (compP2 P) h [v] (syncV (e1) e2) (5 + length (compE2 e1) + length (compE2 e2)) None" by(simp add: τmove2_iff)
  moreover
  have "P,syncV (e1) e2,h  (Val v, x)  ([v], x, length (compE2 (syncV (e1) e2)), None)"
    by(rule bisim1Val2) simp
  moreover have "nat (9 + (int (length (compE2 e1)) + int (length (compE2 e2)))) = 9 + length (compE2 e1) + length (compE2 e2)" by arith
  ultimately show ?case using exec
    by(fastforce elim!: exec_meth.cases simp add: eval_nat_numeral exec_move_def)
next
  case (bisim1Sync7 e1 n e2 V a a' xs)
  note ?exec (syncV (e1) e2) [Addr a'] xs (6 + length (compE2 e1) + length (compE2 e2)) None stk' loc' pc' xcp'
  moreover
  have "P,syncV (e1) e2,h'  (insyncV (a) Throw a', xs) 
        ([xs ! V, Addr a'], xs, 7 + length (compE2 e1) + length (compE2 e2), None)"
    by(rule bisim1Sync8)
  moreover have "τmove2 (compP2 P) h [Addr a'] (syncV (e1) e2) (6 + length (compE2 e1) + length (compE2 e2)) None"
    by(simp add: τmove2_iff)
  ultimately show ?case by(fastforce elim!: exec_meth.cases simp add: eval_nat_numeral exec_move_def)
next
  case (bisim1Sync8 e1 n e2 V a a' xs)
  from n + max_vars (insyncV (a) Throw a')  length xs ‹bsok (syncV (e1) e2) n have V: "V < length xs" by simp
  note ?exec (syncV (e1) e2) [xs ! V, Addr a'] xs (7 + length (compE2 e1) + length (compE2 e2)) None stk' loc' pc' xcp'
  moreover have "¬ τmove2 (compP2 P) h [xs ! V, Addr a'] (syncV (e1) e2) (7 + length (compE2 e1) + length (compE2 e2)) None"
    by(simp add: τmove2_iff)
  moreover
  have "P,syncV (e1) e2,h  (Throw a', xs)  ([Addr a'], xs, 8 + length (compE2 e1) + length (compE2 e2), None)"
    "P,syncV (e1) e2,h  (THROW IllegalMonitorState,xs)  ([xs ! V, Addr a'],xs,7 + length (compE2 e1) + length (compE2 e2),addr_of_sys_xcpt IllegalMonitorState)"
    "P,syncV (e1) e2,h  (THROW NullPointer,xs)  ([Null, Addr a'],xs,7 + length (compE2 e1) + length (compE2 e2),addr_of_sys_xcpt NullPointer)"
    by(rule bisim1Sync9 bisim1Sync14)+
  moreover {
    fix A
    assume "xs ! V = Addr A"
    hence "True,P,t ⊢1 insyncV (a) Throw a',(h, xs) -UnlockA, SyncUnlock A Throw a', (h, xs)"
      "True,P,t ⊢1 insyncV (a) Throw a',(h, xs) -UnlockFailA THROW IllegalMonitorState, (h, xs)"
      using V by(rule Synchronized1Throw2 Synchronized1Throw2Fail[OF TrueI])+ }
  moreover {
    assume "xs ! V = Null"
    hence "True,P,t ⊢1 insyncV (a) Throw a',(h, xs) -ε THROW NullPointer, (h, xs)"
      using V by(rule Synchronized1Throw2Null) }
  moreover have "¬ τmove1 P h (insyncV (a) Throw a')" by fastforce
  ultimately show ?case
    by(fastforce elim!: exec_meth.cases simp add: eval_nat_numeral is_Ref_def ta_bisim_def ta_upd_simps exec_move_def split: if_split_asm)
next
  case (bisim1Sync9 e1 n e2 V a xs)
  note ?exec (syncV (e1) e2) [Addr a] xs (8 + length (compE2 e1) + length (compE2 e2)) None stk' loc' pc' xcp'
  moreover
  have "P,syncV (e1) e2,h  (Throw a, xs)  ([Addr a], xs, 8 + length (compE2 e1) + length (compE2 e2), a)"
    by(rule bisim1Sync10)
  moreover have "τmove2 (compP2 P) h [Addr a] (syncV (e1) e2) (8 + length (compE2 e1) + length (compE2 e2)) None"
    by(rule τmove2Sync8)
  ultimately show ?case
    by(fastforce elim!: exec_meth.cases simp add: eval_nat_numeral exec_move_def split: if_split_asm)
next
  case (bisim1Sync10 e1 n e2 V a xs)
  from ?exec (syncV (e1) e2) [Addr a] xs (8 + length (compE2 e1) + length (compE2 e2)) a stk' loc' pc' xcp'
  have False by(auto elim!: exec_meth.cases simp add: matches_ex_entry_def match_ex_table_append_not_pcs exec_move_def)
  thus ?case ..
next
  case (bisim1Sync11 e1 n e2 V xs)
  from ?exec (syncV (e1) e2) [Null] xs (Suc (Suc (length (compE2 e1)))) addr_of_sys_xcpt NullPointer stk' loc' pc' xcp'
  have False by(auto elim!: exec_meth.cases simp add: matches_ex_entry_def match_ex_table_append_not_pcs exec_move_def)
  thus ?case ..
next
  case (bisim1Sync12 e1 n e2 V a xs v v')
  from ?exec (syncV (e1) e2) [v, v'] xs (4 + length (compE2 e1) + length (compE2 e2)) a stk' loc' pc' xcp'
  have False by(auto elim!: exec_meth.cases simp add: matches_ex_entry_def match_ex_table_append_not_pcs exec_move_def)
  thus ?case ..
next
  case (bisim1Sync14 e1 n e2 V a xs v a')
  from ?exec (syncV (e1) e2) [v, Addr a'] xs (7 + length (compE2 e1) + length (compE2 e2)) a stk' loc' pc' xcp'
  have False by(auto elim!: exec_meth.cases simp add: matches_ex_entry_def match_ex_table_append_not_pcs exec_move_def)
  thus ?case ..
next
  case bisim1InSync thus ?case by simp
next
  case (bisim1SyncThrow e1 n a xs stk loc pc e2 V)
  note exec = ?exec (syncV (e1) e2) stk loc pc a stk' loc' pc' xcp'
  note bisim1 = P,e1,h  (Throw a, xs)  (stk, loc, pc, a)
  from bisim1 have pc: "pc < length (compE2 e1)" by(auto dest: bisim1_ThrowD)
  from bisim1 have "match_ex_table (compP2 P) (cname_of h a) (0 + pc) (compxE2 e1 0 0) = None"
    unfolding compP2_def by(rule  bisim1_xcp_Some_not_caught)
  with exec pc have False
    apply(auto elim!: exec_meth.cases simp add: match_ex_table_append_not_pcs exec_move_def)
    apply(auto dest!: match_ex_table_shift_pcD simp add: matches_ex_entry_def)
    done
  thus ?case ..
next
  case (bisim1Seq1 e1 n e' xs stk loc pc xcp e2)
  note IH = bisim1Seq1.IH(2)
  note exec = ?exec (e1;; e2) stk loc pc xcp stk' loc' pc' xcp'
  note bisim = P,e1,h  (e', xs)  (stk, loc, pc, xcp)
  note len = n + max_vars (e';;e2)  length xs
  note bsok = ‹bsok (e1;; e2) n
  from bisim have pc: "pc  length (compE2 e1)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e1)")
    case True
    let ?post = "Pop # compE2 e2"
    from exec have exec': "?exec e1 stk loc pc xcp stk' loc' pc' xcp'" using True by(simp add: exec_move_Seq1)
    from True have "τmove2 (compP2 P) h stk (e1;;e2) pc xcp = τmove2 (compP2 P) h stk e1 pc xcp" by(simp add: τmove2_iff)
    with IH[OF exec' _ _ P,h  stk [:≤] ST ‹conf_xcp' (compP2 P) h xcp] len bsok show ?thesis
      by(fastforce intro: bisim1_bisims1.bisim1Seq1 Seq1Red elim!: Seq_τred1r_xt Seq_τred1t_xt simp add: no_call2_def)
  next
    case False
    with pc have [simp]: "pc = length (compE2 e1)" by simp
    with bisim obtain v where stk: "stk = [v]" and xcp: "xcp = None"
      by(auto dest: bisim1_pc_length_compE2D)
    with bisim pc len bsok have red: "τred1r P t h (e', xs) (Val v, loc)"
      by(auto intro: bisim1_Val_τred1r simp add: bsok_def)
    hence "τred1r P t h (e';; e2, xs) (Val v;;e2, loc)" by(rule Seq_τred1r_xt)
    also have "τmove1 P h (Val v;;e2)" by(rule τmove1SeqRed)
    hence "τred1r P t h (Val v;;e2, loc) (e2, loc)" by(auto intro: Red1Seq r_into_rtranclp)
    also have τ: "τmove2 (compP2 P) h [v] (e1;;e2) pc None" by(simp add: τmove2_iff)
    moreover from P,e2,h  (e2, loc)  ([], loc, 0, None)
    have "P,e1;;e2,h  (e2, loc)  ([], loc, Suc (length (compE2 e1) + 0), None)"
      by(rule bisim1Seq2)
    ultimately show ?thesis using exec stk xcp
      by(fastforce elim!: exec_meth.cases simp add: exec_move_def)
  qed
next
  case (bisim1SeqThrow1 e1 n a xs stk loc pc e2)
  note exec = ?exec (e1;;e2) stk loc pc a stk' loc' pc' xcp'
  note bisim1 = P,e1,h  (Throw a, xs)  (stk, loc, pc, a)
  from bisim1 have pc: "pc < length (compE2 e1)" by(auto dest: bisim1_ThrowD)
  from bisim1 have "match_ex_table (compP2 P) (cname_of h a) (0 + pc) (compxE2 e1 0 0) = None"
    unfolding compP2_def by(rule  bisim1_xcp_Some_not_caught)
  with exec pc have False
    by(auto elim!: exec_meth.cases simp add: match_ex_table_not_pcs_None exec_move_def)
  thus ?case ..
next
  case (bisim1Seq2 e2 n e' xs stk loc pc xcp e1)
  note IH = bisim1Seq2.IH(2)
  note bisim1 = xs. P,e1,h  (e1, xs)  ([], xs, 0, None)
  note bisim2 = P,e2,h  (e', xs)  (stk, loc, pc, xcp)
  note len = n + max_vars e'  length xs
  note exec = ?exec (e1;; e2) stk loc (Suc (length (compE2 e1) + pc)) xcp stk' loc' pc' xcp'
  note bsok = ‹bsok (e1;; e2) n
  let ?pre = "compE2 e1 @ [Pop]"
  from exec have exec': "exec_meth_d (compP2 P) (?pre @ compE2 e2) (compxE2 e1 0 0 @ shift (length ?pre) (compxE2 e2 0 0)) t h (stk, loc, length ?pre + pc, xcp) ta h' (stk', loc', pc', xcp')"
    by(simp add: shift_compxE2 exec_move_def)
  hence "?exec e2 stk loc pc xcp stk' loc' (pc' - length ?pre) xcp'"
    unfolding exec_move_def by(rule exec_meth_drop_xt, auto)
  from IH[OF this len _ P,h  stk [:≤] ST ‹conf_xcp' (compP2 P) h xcp] bsok obtain e'' xs''
    where bisim': "P,e2,h'  (e'', xs'')  (stk', loc', pc' - length ?pre, xcp')"
    and red: "?red e' xs e'' xs'' e2 stk pc (pc' - length ?pre) xcp xcp'" by auto
  from bisim' 
  have "P,e1;;e2,h'  (e'', xs'')  (stk', loc', Suc (length (compE2 e1) + (pc' - length ?pre)), xcp')"
    by(rule bisim1_bisims1.bisim1Seq2)
  moreover have τ: "τmove2 (compP2 P) h stk (e1;;e2) (Suc (length (compE2 e1) + pc)) xcp = τmove2 (compP2 P) h stk e2 pc xcp"
    by(simp add: τmove2_iff)
  moreover from exec' have "pc'  length ?pre"
    by(rule exec_meth_drop_xt_pc) auto
  ultimately show ?case using red by(fastforce split: if_split_asm simp add: no_call2_def)
next
  case (bisim1Cond1 e n e' xs stk loc pc xcp e1 e2)
  note IH = bisim1Cond1.IH(2)
  note bisim = P,e,h  (e', xs)  (stk, loc, pc, xcp)
  note bisim1 = xs. P,e1,h  (e1, xs)  ([], xs, 0, None)
  note bisim2 = xs. P,e2,h  (e2, xs)  ([], xs, 0, None)
  from n + max_vars (if (e') e1 else e2)  length xs
  have len: "n + max_vars e'  length xs" by simp
  note exec = ?exec (if (e) e1 else e2) stk loc pc xcp stk' loc' pc' xcp'
  note bsok = ‹bsok (if (e) e1 else e2) n
  from bisim have pc: "pc  length (compE2 e)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e)")
    case True
    let ?post = "IfFalse (2 + int (length (compE2 e1))) # compE2 e1 @ Goto (1 + int (length (compE2 e2))) # compE2 e2"
    from exec have exec': "?exec e stk loc pc xcp stk' loc' pc' xcp'" using True
      by(simp add: exec_move_Cond1)
    from True have "τmove2 (compP2 P) h stk (if (e) e1 else e2) pc xcp = τmove2 (compP2 P) h stk e pc xcp"
      by(simp add: τmove2_iff)
    with IH[OF exec' _ _ P,h  stk [:≤] ST ‹conf_xcp' (compP2 P) h xcp] len bsok show ?thesis
      by(fastforce intro: bisim1_bisims1.bisim1Cond1 Cond1Red elim!: Cond_τred1r_xt Cond_τred1t_xt simp add: no_call2_def)
  next
    case False
    with pc have [simp]: "pc = length (compE2 e)" by simp
    with bisim obtain v where stk: "stk = [v]" and xcp: "xcp = None"
      by(auto dest: bisim1_pc_length_compE2D)
    with bisim pc len bsok have red: "τred1r P t h (e', xs) (Val v, loc)"
      by(auto intro: bisim1_Val_τred1r simp add: bsok_def)
    hence "τred1r P t h (if (e') e1 else e2, xs) (if (Val v) e1 else e2, loc)" by(rule Cond_τred1r_xt)
    moreover have "τmove1 P h (if (Val v) e1 else e2)" by(rule τmove1CondRed)
    moreover have τ: "τmove2 (compP2 P) h [v] (if (e) e1 else e2) pc None" by(simp add: τmove2_iff)
    moreover from bisim1[of loc]
    have "P,if (e) e1 else e2,h  (e1, loc)  ([], loc, Suc (length (compE2 e) + 0), None)"
      by(rule bisim1CondThen)
    moreover from bisim2[of loc]
    have "P,if (e) e1 else e2,h  (e2, loc)  ([], loc, Suc (Suc (length (compE2 e) + length (compE2 e1) + 0)), None)"
      by(rule bisim1CondElse)
    moreover have "nat (int (length (compE2 e)) + (2 + int (length (compE2 e1)))) = Suc (Suc (length (compE2 e) + length (compE2 e1) + 0))" by simp
    moreover from exec xcp stk have "typeofh v = Boolean" by(auto simp add: exec_move_def exec_meth_instr)
    ultimately show ?thesis using exec stk xcp
      by(fastforce elim!: exec_meth.cases intro: Red1CondT Red1CondF elim!: rtranclp.rtrancl_into_rtrancl simp add: eval_nat_numeral exec_move_def)
  qed
next
  case (bisim1CondThen e1 n e' xs stk loc pc xcp e e2)
  note IH = bisim1CondThen.IH(2)
  note bisim1 = P,e1,h  (e', xs)  (stk, loc, pc, xcp)
  note bisim = xs. P,e,h  (e, xs)  ([], xs, 0, None)
  note bisim2 = xs. P,e2,h  (e2, xs)  ([], xs, 0, None)
  note len = n + max_vars e'  length xs
  note exec = ?exec (if (e) e1 else e2) stk loc (Suc (length (compE2 e) + pc)) xcp stk' loc' pc' xcp'
  note bsok = ‹bsok (if (e) e1 else e2) n
  from bisim1 have pc: "pc  length (compE2 e1)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e1)")
    case True
    let ?pre = "compE2 e @ [IfFalse (2 + int (length (compE2 e1)))]"
    let ?post = "Goto (1 + int (length (compE2 e2))) # compE2 e2"
    from exec have exec': "exec_meth_d (compP2 P) (?pre @ compE2 e1 @ ?post)
      (compxE2 e 0 0 @ shift (length ?pre) (compxE2 e1 0 0 @ shift (length (compE2 e1)) (compxE2 e2 (Suc 0) 0))) t
      h (stk, loc, length ?pre + pc, xcp) ta h' (stk', loc', pc', xcp')"
      by(simp add: shift_compxE2 ac_simps exec_move_def)
    hence "exec_meth_d (compP2 P) (compE2 e1 @ ?post) (compxE2 e1 0 0 @ shift (length (compE2 e1)) (compxE2 e2 (Suc 0) 0)) t
      h (stk, loc, pc, xcp) ta h' (stk', loc', pc' - length ?pre, xcp')"
      by(rule exec_meth_drop_xt) auto
    hence "exec_move_d P t e1 h (stk, loc, pc, xcp) ta h' (stk', loc', pc' - length ?pre, xcp')"
      using True unfolding exec_move_def by(rule exec_meth_take_xt)
    from IH[OF this len _ P,h  stk [:≤] ST ‹conf_xcp' (compP2 P) h xcp] bsok obtain e'' xs''
      where bisim': "P,e1,h'  (e'', xs'')  (stk', loc', pc' - length ?pre, xcp')"
      and red: "?red e' xs e'' xs'' e1 stk pc (pc' - length ?pre) xcp xcp'" by auto
    from bisim' 
    have "P,if (e) e1 else e2,h'  (e'', xs'')  (stk', loc', Suc (length (compE2 e) + (pc' - length ?pre)), xcp')"
      by(rule bisim1_bisims1.bisim1CondThen)
    moreover from True have τ: "τmove2 (compP2 P) h stk (if (e) e1 else e2) (Suc (length (compE2 e) + pc)) xcp = τmove2 (compP2 P) h stk e1 pc xcp"
      by(simp add: τmove2_iff)
    moreover from exec' have "pc'  length ?pre"
      by(rule exec_meth_drop_xt_pc) auto
    ultimately show ?thesis using red by(fastforce split: if_split_asm simp add: no_call2_def)
  next
    case False
    with pc have [simp]: "pc = length (compE2 e1)" by simp
    with bisim1 obtain v where stk: "stk = [v]" and xcp: "xcp = None"
      by(auto dest: bisim1_pc_length_compE2D)
    with bisim1 pc len bsok have red: "τred1r P t h (e', xs) (Val v, loc)"
      by(auto intro: bisim1_Val_τred1r simp add: bsok_def)
    moreover have τ: "τmove2 (compP2 P) h [v] (if (e) e1 else e2) (Suc (length (compE2 e) + length (compE2 e1))) None"
      by(simp add: τmove2_iff)
    moreover
    have "P,if (e) e1 else e2,h  (Val v, loc)  ([v], loc, length (compE2 (if (e) e1 else e2)), None)"
      by(rule bisim1Val2) simp
    moreover have "nat (2 + (int (length (compE2 e)) + (int (length (compE2 e1)) + int (length (compE2 e2))))) = length (compE2 (if (e) e1 else e2))" by simp
    ultimately show ?thesis using exec xcp stk by(fastforce elim!: exec_meth.cases simp add: exec_move_def)
  qed
next
  case (bisim1CondElse e2 n e' xs stk loc pc xcp e e1)
  note IH = bisim1CondElse.IH(2)
  note bisim2 = P,e2,h  (e', xs)  (stk, loc, pc, xcp)
  note bisim = xs. P,e,h  (e, xs)  ([], xs, 0, None)
  note bisim1 = xs. P,e1,h  (e1, xs)  ([], xs, 0, None)
  note len = n + max_vars e'  length xs
  note exec = ?exec (if (e) e1 else e2) stk loc (Suc (Suc (length (compE2 e) + length (compE2 e1) + pc))) xcp stk' loc' pc' xcp'
  note bsok = ‹bsok (if (e) e1 else e2) n
  let ?pre = "compE2 e @ IfFalse (2 + int (length (compE2 e1))) # compE2 e1 @ [Goto (1 + int (length (compE2 e2)))]"
  from exec have exec': "exec_meth_d (compP2 P) (?pre @ compE2 e2)
    ((compxE2 e 0 0 @ compxE2 e1 (Suc (length (compE2 e))) 0) @ shift (length ?pre) (compxE2 e2 0 0)) t
    h (stk, loc, length ?pre + pc, xcp) ta h' (stk', loc', pc', xcp')"
    by(simp add: shift_compxE2 ac_simps exec_move_def)
  hence "?exec e2 stk loc pc xcp stk' loc' (pc' - length ?pre) xcp'"
    unfolding exec_move_def by(rule exec_meth_drop_xt) auto
  from IH[OF this len _ P,h  stk [:≤] ST ‹conf_xcp' (compP2 P) h xcp] bsok obtain e'' xs''
    where bisim': "P,e2,h'  (e'', xs'')  (stk', loc', pc' - length ?pre, xcp')"
    and red: "?red e' xs e'' xs'' e2 stk pc (pc' - length ?pre) xcp xcp'" by auto
  from bisim'
  have "P,if (e) e1 else e2,h'  (e'', xs'')  (stk', loc', Suc (Suc (length (compE2 e) + length (compE2 e1) + (pc' - length ?pre))), xcp')"
    by(rule bisim1_bisims1.bisim1CondElse)
  moreover have τ: "τmove2 (compP2 P) h stk (if (e) e1 else e2) (Suc (Suc (length (compE2 e) + length (compE2 e1) + pc))) xcp = τmove2 (compP2 P) h stk e2 pc xcp"
    by(simp add: τmove2_iff)
  moreover from exec' have "pc'  length ?pre"
    by(rule exec_meth_drop_xt_pc) auto
  moreover hence "Suc (Suc (pc' - Suc (Suc 0))) = pc'" by simp
  ultimately show ?case using red by(fastforce simp add: eval_nat_numeral no_call2_def split: if_split_asm)
next
  case (bisim1CondThrow e n a xs stk loc pc e1 e2)
  note exec = ?exec (if (e) e1 else e2) stk loc pc a stk' loc' pc' xcp'
  note bisim = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  from bisim have pc: "pc < length (compE2 e)" by(auto dest: bisim1_ThrowD)
  from bisim have "match_ex_table (compP2 P) (cname_of h a) (0 + pc) (compxE2 e 0 0) = None"
    unfolding compP2_def by(rule  bisim1_xcp_Some_not_caught)
  with exec pc have False
    by(auto elim!: exec_meth.cases simp add: match_ex_table_not_pcs_None exec_move_def)
  thus ?case ..
next
  case (bisim1While1 c n e xs)
  note IH = bisim1While1.IH(2)
  note bisim = xs. P,c,h  (c, xs)  ([], xs, 0, None)
  note bisim1 = xs. P,e,h  (e, xs)  ([], xs, 0, None)
  from n + max_vars (while (c) e)  length xs
  have len: "n + max_vars c  length xs" by simp
  note exec = ?exec (while (c) e) [] xs 0 None stk' loc' pc' xcp'
  note bsok = ‹bsok (while (c) e) n
  let ?post = "IfFalse (int (length (compE2 e)) + 3) # compE2 e @ [Pop, Goto (-2 + (- int (length (compE2 e)) - int (length (compE2 c)))), Push Unit]"
  from exec have "?exec c [] xs 0 None stk' loc' pc' xcp'" by(simp add: exec_move_While1)
  from IH[OF this len] bsok obtain e'' xs''
    where bisim': "P,c,h'  (e'', xs'')  (stk', loc', pc', xcp')"
    and red: "?red c xs e'' xs'' c [] 0 pc' None xcp'" by fastforce
  from bisim'
  have "P,while (c) e,h'  (if (e'') (e;;while(c) e) else unit, xs'')  (stk', loc', pc', xcp')"
    by(rule bisim1While3)
  moreover have "True,P,t ⊢1 while (c) e, (h, xs) -ε if (c) (e;;while (c) e) else unit, (h, xs)"
    by(rule Red1While)
  hence "τred1r P t h (while (c) e, xs) (if (c) (e;;while (c) e) else unit, xs)"
    by(auto intro: r_into_rtranclp τmove1WhileRed)
  moreover have "τmove2 (compP2 P) h [] (while (c) e) 0 None = τmove2 (compP2 P) h [] c 0 None" by(simp add: τmove2_iff)
  ultimately show ?case using red
    by(fastforce elim!: rtranclp_trans rtranclp_tranclp_tranclp intro: Cond1Red elim!: Cond_τred1r_xt Cond_τred1t_xt simp add: no_call2_def)
next
  case (bisim1While3 c n e' xs stk loc pc xcp e)
  note IH = bisim1While3.IH(2)
  note bisim = P,c,h  (e', xs)  (stk, loc, pc, xcp)
  note bisim1 = xs. P,e,h  (e, xs)  ([], xs, 0, None)
  from n + max_vars (if (e') (e;;while (c) e) else unit)  length xs
  have len: "n + max_vars e'  length xs" by simp
  note bsok = ‹bsok (while (c) e) n
  note exec = ?exec (while (c) e) stk loc pc xcp stk' loc' pc' xcp'
  from bisim have pc: "pc  length (compE2 c)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 c)")
    case True
    let ?post = "IfFalse (int (length (compE2 e)) + 3) # compE2 e @ [Pop, Goto (-2 + (- int (length (compE2 e)) - int (length (compE2 c)))), Push Unit]"
    from exec have "exec_meth_d (compP2 P) (compE2 c @ ?post) (compxE2 c 0 0 @ shift (length (compE2 c)) (compxE2 e (Suc 0) 0)) t h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
      by(simp add: shift_compxE2 exec_move_def)
    hence "?exec c stk loc pc xcp stk' loc' pc' xcp'"
      using True unfolding exec_move_def by(rule exec_meth_take_xt)
    from IH[OF this len _ P,h  stk [:≤] ST ‹conf_xcp' (compP2 P) h xcp] bsok obtain e'' xs''
      where bisim': "P,c,h'  (e'', xs'')  (stk', loc', pc', xcp')"
      and red: "?red e' xs e'' xs'' c stk pc pc' xcp xcp'" by auto
    from bisim'
    have "P,while (c) e,h'  (if (e'') (e;;while(c) e) else unit, xs'')  (stk', loc', pc', xcp')"
      by(rule bisim1_bisims1.bisim1While3)
    moreover have "τmove2 (compP2 P) h stk (while (c) e) pc xcp = τmove2 (compP2 P) h stk c pc xcp" using True
      by(simp add: τmove2_iff)
    ultimately show ?thesis using red
      by(fastforce elim!: rtranclp_trans intro: Cond1Red elim!: Cond_τred1r_xt Cond_τred1t_xt simp add: no_call2_def)
  next
    case False
    with pc have [simp]: "pc = length (compE2 c)" by simp
    with bisim obtain v where stk: "stk = [v]" and xcp: "xcp = None"
      by(auto dest: bisim1_pc_length_compE2D)
    with bisim pc len bsok  have red: "τred1r P t h (e', xs) (Val v, loc)"
      by(auto intro: bisim1_Val_τred1r simp add: bsok_def)
    hence "τred1r P t h (if (e') (e;; while (c) e) else unit, xs) (if (Val v) (e;; while (c) e) else unit, loc)"
      by(rule Cond_τred1r_xt)
    moreover have τ: "τmove2 (compP2 P) h [v] (while (c) e) (length (compE2 c)) None" by(simp add: τmove2_iff)
    moreover have "τmove1 P h (if (Val v) (e;;while (c) e) else unit)" by(rule τmove1CondRed)
    moreover from bisim1[of loc]
    have "P,while (c) e,h  (e;;while(c) e, loc)  ([], loc, Suc (length (compE2 c) + 0), None)"
      by(rule bisim1While4)
    moreover
    have "P,while (c) e,h  (unit, loc)  ([], loc, Suc (Suc (Suc (length (compE2 c) + length (compE2 e)))), None)"
      by(rule bisim1While7)
    moreover from exec stk xcp have "typeofh v = Boolean"
      by(auto simp add: exec_meth_instr exec_move_def)
    moreover have "nat (int (length (compE2 c)) + (3 + int (length (compE2 e)))) = Suc (Suc (Suc (length (compE2 c) + length (compE2 e))))" by simp
    ultimately show ?thesis using exec stk xcp
      by(fastforce elim!: exec_meth.cases rtranclp_trans intro: Red1CondT Red1CondF simp add: eval_nat_numeral exec_move_def)
  qed
next
  case (bisim1While4 e n e' xs stk loc pc xcp c)
  note IH = bisim1While4.IH(2)
  note bisim = xs. P,c,h  (c, xs)  ([], xs, 0, None)
  note bisim1 = P,e,h  (e', xs)  (stk, loc, pc, xcp)
  from n + max_vars (e';; while (c) e)  length xs
  have len: "n + max_vars e'  length xs" by simp
  note exec = ?exec (while (c) e) stk loc (Suc (length (compE2 c) + pc)) xcp stk' loc' pc' xcp'
  note bsok = ‹bsok (while (c) e) n
  from bisim1 have pc: "pc  length (compE2 e)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e)")
    case True
    let ?pre = "compE2 c @ [IfFalse (int (length (compE2 e)) + 3)]"
    let ?post = "[Pop, Goto (-2 + (- int (length (compE2 e)) - int (length (compE2 c)))), Push Unit]"
    from exec have "exec_meth_d (compP2 P) ((?pre @ compE2 e) @ ?post) (compxE2 c 0 0 @ shift (length ?pre) (compxE2 e 0 0)) t h (stk, loc, length ?pre + pc, xcp) ta h' (stk', loc', pc', xcp')"
      by(simp add: shift_compxE2 exec_move_def)
    hence exec': "exec_meth_d (compP2 P) (?pre @ compE2 e) (compxE2 c 0 0 @ shift (length ?pre) (compxE2 e 0 0)) t h (stk, loc, length ?pre + pc, xcp) ta h' (stk', loc', pc', xcp')"
      by(rule exec_meth_take)(simp add: True)
    hence "?exec e stk loc pc xcp stk' loc' (pc' - length ?pre) xcp'"
      unfolding exec_move_def by(rule exec_meth_drop_xt) auto
    from IH[OF this len _ P,h  stk [:≤] ST ‹conf_xcp' (compP2 P) h xcp] bsok obtain e'' xs''
      where bisim': "P,e,h'  (e'', xs'')  (stk', loc', pc' - length ?pre, xcp')"
      and red: "?red e' xs e'' xs'' e stk pc (pc' - length ?pre) xcp xcp'" by auto
    from red have "?red (e';;while (c) e) xs (e'';;while (c) e) xs'' e stk pc (pc' - length ?pre) xcp xcp'"
      by(fastforce intro: Seq1Red elim!: Seq_τred1r_xt Seq_τred1t_xt split: if_split_asm)
    moreover from bisim'
    have "P,while (c) e,h'  (e'';;while(c) e, xs'')  (stk', loc', Suc (length (compE2 c) + (pc' - length ?pre)), xcp')"
      by(rule bisim1_bisims1.bisim1While4)
    moreover have "τmove2 (compP2 P) h stk (while (c) e) (Suc (length (compE2 c) + pc)) xcp = τmove2 (compP2 P) h stk e pc xcp"
      using True by(simp add: τmove2_iff)
    moreover from exec' have "pc'  length ?pre"
      by(rule exec_meth_drop_xt_pc) auto
    moreover have "no_call2 e pc  no_call2 (while (c) e) (Suc (length (compE2 c) + pc))"
      by(simp add: no_call2_def)
    ultimately show ?thesis
      apply(auto split: if_split_asm)
      apply(fastforce+)[6]
      apply(rule exI conjI|assumption|rule rtranclp.rtrancl_refl|simp)+
      done
  next
    case False
    with pc have [simp]: "pc = length (compE2 e)" by simp
    with bisim1 obtain v where stk: "stk = [v]" and xcp: "xcp = None"
      by(auto dest: bisim1_pc_length_compE2D)
    with bisim1 pc len bsok have red: "τred1r P t h (e', xs) (Val v, loc)"
      by(auto intro: bisim1_Val_τred1r simp add: bsok_def)
    hence "τred1r P t h (e';; while (c) e, xs) (Val v;; while (c) e, loc)" by(rule Seq_τred1r_xt)
    moreover have τ: "τmove2 (compP2 P) h [v] (while (c) e) (Suc (length (compE2 c) + length (compE2 e))) None"
      by(simp add: τmove2_iff)
    moreover have "τmove1 P h (Val v;;while (c) e)" by(rule τmove1SeqRed)
    moreover
    have "P,while (c) e,h  (while(c) e, loc)  ([], loc, Suc (Suc (length (compE2 c) + length (compE2 e))), None)"
      by(rule bisim1While6)
    ultimately show ?thesis using exec stk xcp
      by(fastforce elim!: exec_meth.cases rtranclp_trans intro: Red1Seq simp add: eval_nat_numeral exec_move_def)
  qed
next
  case (bisim1While6 c n e xs)
  note exec = ?exec (while (c) e) [] xs (Suc (Suc (length (compE2 c) + length (compE2 e)))) None stk' loc' pc' xcp'
  moreover have "τmove2 (compP2 P) h [] (while (c) e) (Suc (Suc (length (compE2 c) + length (compE2 e)))) None"
    by(simp add: τmove2_iff)
  moreover
  have "P,while (c) e,h'  (if (c) (e;; while (c) e) else unit, xs)  ([], xs, 0, None)"
    by(rule bisim1While3[OF bisim1_refl])
  moreover have "τred1t P t h (while (c) e, xs) (if (c) (e;; while (c) e) else unit, xs)"
    by(rule tranclp.r_into_trancl)(auto intro: Red1While)
  ultimately show ?case
    by(fastforce elim!: exec_meth.cases simp add: exec_move_def)
next
  case (bisim1While7 c n e xs)
  note ?exec (while (c) e) [] xs (Suc (Suc (Suc (length (compE2 c) + length (compE2 e))))) None stk' loc' pc' xcp'
  moreover have "τmove2 (compP2 P) h [] (while (c) e) (Suc (Suc (Suc (length (compE2 c) + length (compE2 e))))) None"
    by(simp add: τmove2_iff)
  moreover have "P,while (c) e,h'  (unit, xs)  ([Unit], xs, length (compE2 (while (c) e)), None)"
    by(rule bisim1Val2) simp
  ultimately show ?case by(fastforce elim!: exec_meth.cases simp add: exec_move_def)
next
  case (bisim1WhileThrow1 c n a xs stk loc pc e)
  note exec = ?exec (while (c) e) stk loc pc a stk' loc' pc' xcp'
  note bisim1 = P,c,h  (Throw a, xs)  (stk, loc, pc, a)
  from bisim1 have pc: "pc < length (compE2 c)" by(auto dest: bisim1_ThrowD)
  from bisim1 have "match_ex_table (compP2 P) (cname_of h a) (0 + pc) (compxE2 c 0 0) = None"
    unfolding compP2_def by(rule  bisim1_xcp_Some_not_caught)
  with exec pc have False
    by(auto elim!: exec_meth.cases simp add: match_ex_table_not_pcs_None exec_move_def)
  thus ?case ..
next
  case (bisim1WhileThrow2 e n a xs stk loc pc c)
  note exec = ?exec (while (c) e) stk loc (Suc (length (compE2 c) + pc)) a stk' loc' pc' xcp'
  note bisim = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  from bisim have pc: "pc < length (compE2 e)" by(auto dest: bisim1_ThrowD)
  from bisim have "match_ex_table (compP2 P) (cname_of h a) (0 + pc) (compxE2 e 0 0) = None"
    unfolding compP2_def by(rule  bisim1_xcp_Some_not_caught)
  with exec pc have False
    apply(auto elim!: exec_meth.cases simp add: match_ex_table_not_pcs_None exec_move_def)
    apply(auto dest!: match_ex_table_shift_pcD simp only: compxE2_size_convs)
    apply simp
    done
  thus ?case ..
next
  case (bisim1Throw1 e n e' xs stk loc pc xcp)
  note IH = bisim1Throw1.IH(2)
  note exec = ?exec (throw e) stk loc pc xcp stk' loc' pc' xcp'
  note bisim = P,e,h  (e', xs)  (stk, loc, pc, xcp)
  note len = n + max_vars (throw e')  length xs
  note bsok = ‹bsok (throw e) n
  from bisim have pc: "pc  length (compE2 e)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e)")
    case True
    with exec have exec': "?exec e stk loc pc xcp stk' loc' pc' xcp'" by(simp add: exec_move_Throw)
    from True have "τmove2 (compP2 P) h stk (throw e) pc xcp = τmove2 (compP2 P) h stk e pc xcp" by(simp add: τmove2_iff)
    with IH[OF exec' _ _ P,h  stk [:≤] ST ‹conf_xcp' (compP2 P) h xcp] len bsok show ?thesis
      by(fastforce intro: bisim1_bisims1.bisim1Throw1 Throw1Red elim!: Throw_τred1r_xt Throw_τred1t_xt simp add: no_call2_def)
  next
    case False
    with pc have [simp]: "pc = length (compE2 e)" by simp
    with bisim obtain v where stk: "stk = [v]" and xcp: "xcp = None"
      by(auto dest: bisim1_pc_length_compE2D)
    with bisim pc len bsok have red: "τred1r P t h (e', xs) (Val v, loc)"
      by(auto intro: bisim1_Val_τred1r simp add: bsok_def)
    hence "τred1r P t h (throw e', xs) (throw (Val v), loc)" by(rule Throw_τred1r_xt)
    moreover have τ: "τmove2 (compP2 P) h [v] (throw e) pc None" by(simp add: τmove2_iff)
    moreover 
    have "a. P,throw e,h  (Throw a, loc)  ([Addr a], loc, length (compE2 e), a)"
      by(rule bisim1Throw2)
    moreover
    have "P,throw e,h  (THROW NullPointer, loc)  ([Null], loc, length (compE2 e), addr_of_sys_xcpt NullPointer)"
      by(rule bisim1ThrowNull)
    moreover from exec stk xcp P,h  stk [:≤] ST obtain T' where T': "typeofh v = T'" "P  T'  Class Throwable"
      by(auto simp add: exec_move_def exec_meth_instr list_all2_Cons1 conf_def compP2_def)
    moreover with T' have "v  Null  C. T' = Class C" by(cases T')(auto dest: Array_widen)
    moreover have "τred1r P t h (throw null, loc) (THROW NullPointer, loc)"
      by(auto intro: r_into_rtranclp Red1ThrowNull τmove1ThrowNull)
    ultimately show ?thesis using exec stk xcp T' unfolding exec_move_def
      by(cases v)(fastforce elim!: exec_meth.cases intro: rtranclp_trans)+
  qed
next
  case (bisim1Throw2 e n a xs)
  note exec = ?exec (throw e) [Addr a] xs (length (compE2 e)) a stk' loc' pc' xcp'
  hence False by(auto elim!: exec_meth.cases dest: match_ex_table_pc_length_compE2 simp add: exec_move_def)
  thus ?case ..
next
  case (bisim1ThrowNull e n xs)
  note exec = ?exec (throw e) [Null] xs (length (compE2 e)) addr_of_sys_xcpt NullPointer stk' loc' pc' xcp'
  hence False by(auto elim!: exec_meth.cases dest: match_ex_table_pc_length_compE2 simp add: exec_move_def)
  thus ?case ..
next
  case (bisim1ThrowThrow e n a xs stk loc pc)
  note exec = ?exec (throw e) stk loc pc a stk' loc' pc' xcp'
  note bisim1 = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  from bisim1 have pc: "pc < length (compE2 e)" by(auto dest: bisim1_ThrowD)
  from bisim1 have "match_ex_table (compP2 P) (cname_of h a) (0 + pc) (compxE2 e 0 0) = None"
    unfolding compP2_def by(rule  bisim1_xcp_Some_not_caught)
  with exec pc have False by(auto elim!: exec_meth.cases simp add: exec_move_def)
  thus ?case ..
next
  case (bisim1Try e n e' xs stk loc pc xcp e2 C' V)
  note IH = bisim1Try.IH(2)
  note bisim = P,e,h  (e', xs)  (stk, loc, pc, xcp)
  note bisim1 = xs. P,e2,h  (e2, xs)  ([], xs, 0, None)
  note exec = ?exec (try e catch(C' V) e2) stk loc pc xcp stk' loc' pc' xcp'
  note bsok = ‹bsok (try e catch(C' V) e2) n
  with n + max_vars (try e' catch(C' V) e2)  length xs
  have len: "n + max_vars e'  length xs" and V: "V < length xs" by simp_all
  from bisim have pc: "pc  length (compE2 e)" by(rule bisim1_pc_length_compE2)
  show ?case
  proof(cases "pc < length (compE2 e)")
    case True
    note pc = True
    show ?thesis
    proof(cases "xcp = None  (a'. xcp = a'  match_ex_table (compP2 P) (cname_of h a') pc (compxE2 e 0 0)  None)")
      case False
      then obtain a' where Some: "xcp = a'" 
        and True: "match_ex_table (compP2 P) (cname_of h a') pc (compxE2 e 0 0) = None" by(auto simp del: not_None_eq)
      from Some bisim ‹conf_xcp' (compP2 P) h xcp have "C. typeofh (Addr a') = Class C  P  C * Throwable"
        by(auto simp add: compP2_def)
      then obtain C'' where ha': "typeof_addr h a' = Class_type C''" 
        and subclsThrow: "P  C'' * Throwable" by(auto)
      with exec True Some pc have subcls: "P  C'' * C'"
        apply(auto elim!: exec_meth.cases simp add: match_ex_table_append compP2_def matches_ex_entry_def exec_move_def cname_of_def split: if_split_asm)
        apply(simp only: compxE2_size_convs, simp)
        done
      moreover from ha' subclsThrow bsok have red: "τred1r P t h (e', xs) (Throw a', loc)"
        and bisim': "P,e,h  (Throw a', loc)  (stk, loc, pc, a')" using bisim True len
        unfolding Some compP2_def by(auto dest!: bisim1_xcp_τRed simp add: bsok_def)
      from red have lenloc: "length loc = length xs" by(rule τred1r_preserves_len)
      from red have "τred1r P t h (try e' catch(C' V) e2, xs) (try (Throw a') catch(C' V) e2, loc)"
        by(rule Try_τred1r_xt)
      hence "τred1r P t h (try e' catch(C' V) e2, xs) ({V:Class C'=None; e2}, loc[V := Addr a'])"
        using ha' subcls V unfolding lenloc[symmetric]
        by(auto intro: rtranclp.rtrancl_into_rtrancl Red1TryCatch τmove1TryThrow)
      moreover from pc have "τmove2 (compP2 P) h stk (try e catch(C' V) e2) pc a'" by(simp add: τmove2_iff)
      moreover from bisim' ha' subcls
      have "P,try e catch(C' V) e2,h  ({V:Class C'=None; e2}, loc[V := Addr a'])  ([Addr a'], loc, Suc (length (compE2 e)), None)"
        by(rule bisim1TryCatch1)
      ultimately show ?thesis using exec True pc Some ha' subclsThrow
        apply(auto elim!: exec_meth.cases simp add: ac_simps eval_nat_numeral match_ex_table_append matches_ex_entry_def compP2_def exec_move_def cname_of_def)
        apply fastforce
        apply(simp_all only: compxE2_size_convs, auto dest: match_ex_table_shift_pcD)
        done
    next
      case True
      let ?post = "Goto (int (length (compE2 e2)) + 2) # Store V # compE2 e2"
      from exec True have "exec_meth_d (compP2 P) (compE2 e @ ?post) (compxE2 e 0 0 @ shift (length (compE2 e)) (compxE2 e2 (Suc (Suc 0)) 0)) t h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
        by(auto elim!: exec_meth.cases intro: exec_meth.intros simp add: match_ex_table_append shift_compxE2 exec_move_def)
      hence "?exec e stk loc pc xcp stk' loc' pc' xcp'"
        using pc unfolding exec_move_def by(rule exec_meth_take_xt)
      from IH[OF this len _ P,h  stk [:≤] ST ‹conf_xcp' (compP2 P) h xcp] bsok obtain e'' xs''
        where bisim': "P,e,h'  (e'', xs'')  (stk', loc', pc', xcp')"
        and red': "?red e' xs e'' xs'' e stk pc pc' xcp xcp'" by auto
      from bisim'
      have "P,try e catch(C' V) e2,h'  (try e'' catch(C' V) e2, xs'')  (stk', loc', pc', xcp')"
        by(rule bisim1_bisims1.bisim1Try)
      moreover from pc have "τmove2 (compP2 P) h stk (try e catch(C' V) e2) pc xcp = τmove2 (compP2 P) h stk e pc xcp"
        by(simp add: τmove2_iff)
      ultimately show ?thesis using red' by(fastforce intro: Try1Red elim!: Try_τred1r_xt Try_τred1t_xt simp add: no_call2_def)
    qed
  next
    case False
    with pc have [simp]: "pc = length (compE2 e)" by simp
    with bisim obtain v where stk: "stk = [v]" and xcp: "xcp = None"
      by(auto dest: bisim1_pc_length_compE2D)
    with bisim pc len bsok have red: "τred1r P t h (e', xs) (Val v, loc)"
      by(auto intro: bisim1_Val_τred1r simp add: bsok_def)
    hence "τred1r P t h (try e' catch(C' V) e2, xs) (try (Val v) catch(C' V) e2, loc)" by(rule Try_τred1r_xt)
    hence "τred1r P t h (try e' catch(C' V) e2, xs) (Val v, loc)"
      by(auto intro: rtranclp.rtrancl_into_rtrancl Red1Try τmove1TryRed)
    moreover have τ: "τmove2 (compP2 P) h [v] (try e catch(C' V) e2) pc None" by(simp add: τmove2_iff)
    moreover
    have "P,try e catch(C' V) e2,h  (Val v, loc)  ([v], loc, length (compE2 (try e catch(C' V) e2)), None)"
      by(rule bisim1Val2) simp
    moreover have "nat (int (length (compE2 e)) + (int (length (compE2 e2)) + 2)) = length (compE2 (try e catch(C' V) e2))" by simp
    ultimately show ?thesis using exec stk xcp
      by(fastforce elim!: exec_meth.cases simp add: exec_move_def)
  qed
next
  case (bisim1TryCatch1 e n a xs stk loc pc C'' C' e2 V)
  note exec = ?exec (try e catch(C' V) e2) [Addr a] loc (Suc (length (compE2 e))) None stk' loc' pc' xcp'
  note bisim2 = P,e2,h  (e2, loc[V := Addr a])  ([], loc[V := Addr a], 0, None)
  note bisim1 = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  hence [simp]: "xs = loc" by(auto dest: bisim1_ThrowD)
  from bisim2
  have "P, try e catch(C' V) e2, h  ({V:Class C'=None; e2}, loc[V := Addr a])  ([], loc[V := Addr a], Suc (Suc (length (compE2 e) + 0)), None)"
    by(rule bisim1TryCatch2)
  moreover have "τmove2 (compP2 P) h [Addr a] (try e catch(C' V) e2) (Suc (length (compE2 e))) None" by(simp add: τmove2_iff)
  ultimately show ?case using exec by(fastforce elim!: exec_meth.cases simp add: exec_move_def)
next
  case (bisim1TryCatch2 e2 n e' xs stk loc pc xcp e C' V)
  note IH = bisim1TryCatch2.IH(2)
  note bisim2 = P,e2,h  (e', xs)  (stk, loc, pc, xcp)
  note bisim = xs. P,e,h  (e, xs)  ([], xs, 0, None)
  note exec = ?exec (try e catch(C' V) e2) stk loc (Suc (Suc (length (compE2 e) + pc))) xcp stk' loc' pc' xcp'
  note bsok = ‹bsok (try e catch(C' V) e2) n
  with n + max_vars {V:Class C'=None; e'}  length xs
  have len: "Suc n + max_vars e'  length xs" and V: "V < length xs" by simp_all
  let ?pre = "compE2 e @ [Goto (int (length (compE2 e2)) + 2), Store V]"
  from exec have "exec_meth_d (compP2 P) (?pre @ compE2 e2)
    (compxE2 e 0 0 @ shift (length ?pre) (compxE2 e2 0 0) @ [(0, length (compE2 e), C', Suc (length (compE2 e)), 0)]) t
    h (stk, loc, length ?pre + pc, xcp) ta h' (stk', loc', pc', xcp')"
    by(simp add: shift_compxE2 exec_move_def)
  hence exec': "exec_meth_d (compP2 P) (?pre @ compE2 e2) (compxE2 e 0 0 @ shift (length ?pre) (compxE2 e2 0 0)) t
     h (stk, loc, length ?pre + pc, xcp) ta h' (stk', loc', pc', xcp')"
    by(auto elim!: exec_meth.cases intro: exec_meth.intros simp add: match_ex_table_append matches_ex_entry_def)
  hence "?exec e2 stk loc pc xcp stk' loc' (pc' - length ?pre) xcp'"
    unfolding exec_move_def by(rule exec_meth_drop_xt) auto
  from IH[OF this len _ P,h  stk [:≤] ST ‹conf_xcp' (compP2 P) h xcp] bsok obtain e'' xs''
    where bisim': "P,e2,h'  (e'', xs'')  (stk', loc', pc' - length ?pre, xcp')"
    and red: "?red e' xs e'' xs'' e2 stk pc (pc' - length ?pre) xcp xcp'" by auto
  from red have "length xs'' = length xs"
    by(auto dest!: τred1r_preserves_len τred1t_preserves_len red1_preserves_len split: if_split_asm)
  with red V have "?red {V:Class C'=None; e'} xs {V:Class C'=None; e''} xs'' e2 stk pc (pc' - length ?pre) xcp xcp'"
    by(fastforce elim!: Block_None_τred1r_xt Block_None_τred1t_xt intro: Block1Red split: if_split_asm)
  moreover
  from bisim'
  have "P,try e catch(C' V) e2,h'  ({V:Class C'=None;e''}, xs'')  (stk', loc', Suc (Suc (length (compE2 e) + (pc' - length ?pre))), xcp')"
    by(rule bisim1_bisims1.bisim1TryCatch2)
  moreover have "τmove2 (compP2 P) h stk (try e catch(C' V) e2) (Suc (Suc (length (compE2 e) + pc))) xcp = τmove2 (compP2 P) h stk e2 pc xcp"
    by(simp add: τmove2_iff)
  moreover from exec' have "pc'  length ?pre"
    by(rule exec_meth_drop_xt_pc) auto
  moreover hence "Suc (Suc (pc' - Suc (Suc 0))) = pc'" by simp
  moreover have "no_call2 e2 pc  no_call2 (try e catch(C' V) e2) (Suc (Suc (length (compE2 e) + pc)))"
    by(simp add: no_call2_def)
  ultimately show ?case using red V by(fastforce simp add: eval_nat_numeral split: if_split_asm)
next
  case (bisim1TryFail e n a xs stk loc pc C'' C' e2 V)
  note bisim = P,e,h  (Throw a, xs)  (stk, loc, pc, a)
  from bisim have pc: "pc < length (compE2 e)" by(auto dest: bisim1_ThrowD)
  from bisim have "match_ex_table (compP2 P) (cname_of h a) (0 + pc) (compxE2 e 0 0) = None"
    unfolding compP2_def by(rule  bisim1_xcp_Some_not_caught)
  with ?exec (try e catch(C' V) e2) stk loc pc a stk' loc' pc' xcp' pc typeof_addr h a = Class_type C'' ¬ P  C'' * C'
  have False by(auto elim!: exec_meth.cases simp add: matches_ex_entry_def compP2_def match_ex_table_append_not_pcs exec_move_def cname_of_def)
  thus ?case ..
next
  case (bisim1TryCatchThrow e2 n a xs stk loc pc e C' V)
  note bisim = P,e2,h  (Throw a, xs)  (stk, loc, pc, a)
  from bisim have pc: "pc < length (compE2 e2)" by(auto dest: bisim1_ThrowD)
  from bisim have "match_ex_table (compP2 P) (cname_of h a) (0 + pc) (compxE2 e2 0 0) = None"
    unfolding compP2_def by(rule  bisim1_xcp_Some_not_caught)
  with ?exec (try e catch(C' V) e2) stk loc (Suc (Suc (length (compE2 e) + pc))) a stk' loc' pc' xcp' pc
  have False apply(auto elim!: exec_meth.cases simp add: compxE2_size_convs match_ex_table_append_not_pcs exec_move_def)
    apply(auto dest!: match_ex_table_shift_pcD simp add: match_ex_table_append matches_ex_entry_def compP2_def)
    done
  thus ?case ..
next
  case bisims1Nil
  hence False by(auto elim!: exec_meth.cases simp add: exec_moves_def)
  thus ?case ..
next
  case (bisims1List1 e n e' xs stk loc pc xcp es)
  note IH1 = bisims1List1.IH(2)
  note IH2 = bisims1List1.IH(4)
  note exec = ?execs (e # es) stk loc pc xcp stk' loc' pc' xcp'
  note bisim1 = P,e,h  (e', xs)  (stk, loc, pc, xcp)
  note bisim2 = P,es,h  (es, loc) [↔] ([], loc, 0, None)
  note len = n + max_varss (e' # es)  length xs
  note bsok = ‹bsoks (e # es) n
  from bisim1 have pc: "pc  length (compE2 e)" by(rule bisim1_pc_length_compE2)
  from bisim1 have lenxs: "length xs = length loc" by(rule bisim1_length_xs)
  show ?case
  proof(cases "pc < length (compE2 e)")
    case True
    with exec have exec': "?exec e stk loc pc xcp stk' loc' pc' xcp'"
      by(auto simp add: compxEs2_size_convs exec_moves_def exec_move_def intro: exec_meth_take_xt)
    from True have "τmoves2 (compP2 P) h stk (e # es) pc xcp = τmove2 (compP2 P) h stk e pc xcp"
      by(simp add: τmove2_iff τmoves2_iff)
    moreover from True have "no_calls2 (e # es) pc = no_call2 e pc"
      by(simp add: no_call2_def no_calls2_def)
    ultimately show ?thesis
      using IH1[OF exec' _ _ P,h  stk [:≤] ST ‹conf_xcp' (compP2 P) h xcp] bsok len 
      by(fastforce intro: bisim1_bisims1.bisims1List1 elim!: τred1r_inj_τreds1r τred1t_inj_τreds1t List1Red1)
  next
    case False
    with pc have pc [simp]: "pc = length (compE2 e)" by simp
    with bisim1 obtain v where stk: "stk = [v]" and xcp: "xcp = None"
      and v: "is_val e'  e' = Val v  xs = loc" and call: "call1 e' = None"
      by(auto dest: bisim1_pc_length_compE2D)
    with bisim1 pc len bsok have red: "τred1r P t h (e', xs) (Val v, loc)"
      by(auto intro: bisim1_Val_τred1r simp add: bsok_def)
    hence "τreds1r P t h (e' # es, xs) (Val v # es, loc)" by(rule τred1r_inj_τreds1r)
    moreover from exec stk xcp
    have exec': "exec_meth_d (compP2 P) (compE2 e @ compEs2 es) (compxE2 e 0 0 @ shift (length (compE2 e)) (stack_xlift (length [v]) (compxEs2 es 0 0))) t h ([] @ [v], loc, length (compE2 e) + 0, None) ta h' (stk', loc', pc', xcp')"
      by(simp add: shift_compxEs2 stack_xlift_compxEs2 exec_moves_def)
    hence "exec_meth_d (compP2 P) (compEs2 es) (stack_xlift (length [v]) (compxEs2 es 0 0)) t h ([] @ [v], loc, 0, None) ta h' (stk', loc', pc' - length (compE2 e), xcp')"
      by(rule exec_meth_drop_xt) auto
    with bisim2 obtain stk'' where stk': "stk' = stk'' @ [v]"
      and exec'': "exec_moves_d P t es h ([], loc, 0, None) ta h' (stk'', loc', pc' - length (compE2 e), xcp')"
      by(unfold exec_moves_def)(drule (1) exec_meth_stk_splits, auto)
    from IH2[OF exec''] len lenxs bsok obtain es'' xs''
      where bisim': "P,es,h'  (es'', xs'') [↔] (stk'', loc', pc' - length (compE2 e), xcp')"
      and red': "?reds es loc es'' xs'' es [] 0 (pc' - length (compE2 e)) None xcp'" by fastforce
    from bisim' have "P,e # es,h'  (Val v # es'', xs'') [↔] (stk'' @ [v], loc', length (compE2 e) + (pc' - length (compE2 e)), xcp')"
      by(rule bisims1List2)
    moreover from exec''
    have "τmoves2 (compP2 P) h [v] (e # es) (length (compE2 e)) None = τmoves2 (compP2 P) h [] es 0 None"
      using τinstr_stk_drop_exec_moves[where stk="[]" and vs="[v]"] by(simp add: τmoves2_iff)
    moreover have τ: "es'. τmoves1 P h (Val v # es')  τmoves1 P h es'" by simp
    from exec' have "pc'  length (compE2 e)"
      by(rule exec_meth_drop_xt_pc) auto
    moreover have "no_calls2 es 0  no_calls2 (e # es) (length (compE2 e))"
      by(simp add: no_calls2_def)
    ultimately show ?thesis using red' xcp stk stk' call v
      apply(auto simp add: split_paired_Ex)
      apply(blast 25 intro: rtranclp_trans rtranclp_tranclp_tranclp τreds1r_cons_τreds1r List1Red2 τreds1t_cons_τreds1t dest: τ)+
      done
  qed
next
  case (bisims1List2 es n es' xs stk loc pc xcp e v)
  note IH = bisims1List2.IH(2)
  note exec = ?execs (e # es) (stk @ [v]) loc (length (compE2 e) + pc) xcp stk' loc' pc' xcp'
  note bisim1 = P,e,h  (e, xs)  ([], xs, 0, None)
  note bisim2 = P,es,h  (es', xs) [↔] (stk, loc, pc, xcp)
  note len = n + max_varss (Val v # es')  length xs
  note bsok = ‹bsoks (e # es) n
  from P,h  stk @ [v] [:≤] ST obtain ST' where ST': "P,h  stk [:≤] ST'"
    by(auto simp add: list_all2_append1)
  from exec have exec': "exec_meth_d (compP2 P) (compE2 e @ compEs2 es) (compxE2 e 0 0 @ shift (length (compE2 e)) (stack_xlift (length [v]) (compxEs2 es 0 0))) t h (stk @ [v], loc, length (compE2 e) + pc, xcp) ta h' (stk', loc', pc', xcp')"
    by(simp add: shift_compxEs2 stack_xlift_compxEs2 exec_moves_def)
  hence "exec_meth_d (compP2 P) (compEs2 es) (stack_xlift (length [v]) (compxEs2 es 0 0)) t h (stk @ [v], loc, pc, xcp) ta h' (stk', loc', pc' - length (compE2 e), xcp')"
    by(rule exec_meth_drop_xt) auto
  with bisim2 obtain stk'' where stk': "stk' = stk'' @ [v]"
    and exec'': "exec_moves_d P t es h (stk, loc, pc, xcp) ta h' (stk'', loc', pc' - length (compE2 e), xcp')"
    by(unfold exec_moves_def)(drule (1) exec_meth_stk_splits, auto)
  from IH[OF exec'' _ _ ST' ‹conf_xcp' (compP2 P) h xcp] len bsok obtain es'' xs''
    where bisim': "P,es,h'  (es'', xs'') [↔] (stk'', loc', pc' - length (compE2 e), xcp')"
    and red': "?reds es' xs es'' xs'' es stk pc (pc' - length (compE2 e)) xcp xcp'" by auto
  from bisim' have "P,e # es,h'  (Val v # es'', xs'') [↔] (stk'' @ [v], loc', length (compE2 e) + (pc' - length (compE2 e)), xcp')"
    by(rule bisim1_bisims1.bisims1List2)
  moreover from exec'' have "τmoves2 (compP2 P) h (stk @ [v]) (e # es) (length (compE2 e) + pc) xcp = τmoves2 (compP2 P) h stk es pc xcp"
    by(auto simp add: τmoves2_iff τinstr_stk_drop_exec_moves)
  moreover have τ: "es'. τmoves1 P h (Val v # es')  τmoves1 P h es'" by simp
  from exec' have "pc'  length (compE2 e)"
    by(rule exec_meth_drop_xt_pc) auto
  moreover have "no_calls2 es pc  no_calls2 (e # es) (length (compE2 e) + pc)"
    by(simp add: no_calls2_def)
  ultimately show ?case using red' stk'
    by(auto split: if_split_asm simp add: split_paired_Ex)(blast intro: rtranclp_trans rtranclp_tranclp_tranclp τreds1r_cons_τreds1r List1Red2 τreds1t_cons_τreds1t dest: τ)+
qed

end

inductive sim21_size_aux :: "nat  (pc × 'addr option)  (pc × 'addr option)  bool"
for len :: nat
where
  " pc1  len; pc2  len; xcp1  None  xcp2 = None  pc1 = pc2  xcp1 = None  pc1 > pc2 
   sim21_size_aux len (pc1, xcp1) (pc2, xcp2)"

definition sim21_size :: "'addr jvm_prog  'addr jvm_thread_state  'addr jvm_thread_state  bool"
where
  "sim21_size P xcpfrs xcpfrs' 
   (xcpfrs, xcpfrs')  
   inv_image (less_than <*lex*> same_fst (λn. True) (λn. {(pcxcp, pcxcp'). sim21_size_aux n pcxcp pcxcp'}))
             (λ(xcp, frs). (length frs, case frs of []  undefined
                          | (stk, loc, C, M, pc) # frs  (length (fst (snd (snd (the (snd (snd (snd (method P C M)))))))), pc, xcp)))"

lemma wfP_sim21_size_aux: "wfP (sim21_size_aux n)"
proof -
  let ?f = "λ(pc, xcp). case xcp of None  Suc (2 * (n - pc)) | Some _  2 * (n - pc)"
  have "wf {(m, m'). (m :: nat) < m'}" by(rule wf_less)
  hence "wf (inv_image {(m, m'). m < m'} ?f)" by(rule wf_inv_image)
  moreover have "{(pcxcp1, pcxcp2). sim21_size_aux n pcxcp1 pcxcp2}  inv_image {(m, m'). m < m'} ?f"
    by(auto elim!: sim21_size_aux.cases)
  ultimately show ?thesis unfolding wfP_def by(rule wf_subset)
qed

lemma Collect_split_mem: "{(x, y). (x, y)  Q} = Q" by simp

lemma wfP_sim21_size: "wfP (sim21_size P)"
unfolding wfP_def Collect_split_mem sim21_size_def [abs_def]
apply(rule wf_inv_image)
apply(rule wf_lex_prod)
 apply(rule wf_less_than)
apply(rule wf_same_fst)
apply(rule wfP_sim21_size_aux[unfolded wfP_def])
done

declare split_beta[simp]

context J1_JVM_heap_base begin

lemma bisim1_Invoke_τRed:
  " P,E,h  (e, xs)  (rev vs @ Addr a # stk', loc, pc, None); pc < length (compE2 E);
     compE2 E ! pc = Invoke M (length vs); n + max_vars e  length xs; bsok E n 
   e' xs'. τred1r P t h (e, xs) (e', xs')  P,E,h  (e', xs')  (rev vs @ Addr a # stk', loc, pc, None)  call1 e' = (a, M, vs)"
  (is " _; _; _; _; _   ?concl e xs E n pc stk' loc")

  and bisims1_Invoke_τReds:
  " P,Es,h  (es, xs) [↔] (rev vs @ Addr a # stk', loc, pc, None); pc < length (compEs2 Es);
    compEs2 Es ! pc = Invoke M (length vs); n + max_varss es  length xs; bsoks Es n 
   es' xs'. τreds1r P t h (es, xs) (es', xs')  P,Es,h  (es', xs') [↔] (rev vs @ Addr a # stk', loc, pc, None)  calls1 es' = (a, M, vs)"
  (is " _; _; _; _; _   ?concls es xs Es n pc stk' loc")
proof(induct E n e xs stk"rev vs @ Addr a # stk'" loc pc xcp"None::'addr option"
  and Es n es xs stk"rev vs @ Addr a # stk'" loc pc xcp"None::'addr option"
  arbitrary: stk' and stk' rule: bisim1_bisims1_inducts_split)
  case bisim1Val2 thus ?case by simp
next
  case bisim1New thus ?case by simp
next
  case bisim1NewArray thus ?case
    by(fastforce split: if_split_asm intro: bisim1_bisims1.bisim1NewArray dest: bisim1_pc_length_compE2 elim!: NewArray_τred1r_xt)
next
  case bisim1Cast thus ?case
    by(fastforce split: if_split_asm intro: bisim1_bisims1.bisim1Cast dest: bisim1_pc_length_compE2 elim!: Cast_τred1r_xt)
next
  case bisim1InstanceOf thus ?case
    by(fastforce split: if_split_asm intro: bisim1_bisims1.bisim1InstanceOf dest: bisim1_pc_length_compE2 elim!: InstanceOf_τred1r_xt)
next
  case bisim1Val thus ?case by simp
next
  case bisim1Var thus ?case by simp
next
  case bisim1BinOp1 thus ?case
    apply(auto split: if_split_asm intro: bisim1_bisims1.bisim1BinOp1 dest: bisim1_pc_length_compE2 elim: BinOp_τred1r_xt1)
    apply(fastforce elim!: BinOp_τred1r_xt1 intro: bisim1_bisims1.bisim1BinOp1)
    done
next
  case (bisim1BinOp2 e2 n e' xs stk loc pc e1 bop v1)
  note IH = stk'. stk = rev vs @ Addr a # stk'; pc < length (compE2 e2); compE2 e2 ! pc = Invoke M (length vs); n + max_vars e'  length xs; bsok e2 n
                        ?concl e' xs e2 n pc stk' loc
  note inv = ‹compE2 (e1 «bop» e2) ! (length (compE2 e1) + pc) = Invoke M (length vs)
  with ‹length (compE2 e1) + pc < length (compE2 (e1 «bop» e2)) have pc: "pc < length (compE2 e2)"
    by(auto split: bop.splits if_split_asm)
  moreover with inv have "compE2 e2 ! pc = Invoke M (length vs)" by simp
  moreover with P,e2,h  (e', xs)  (stk, loc, pc, None) pc
  obtain vs'' v'' stk'' where "stk = vs'' @ v'' # stk''" and "length vs'' = length vs"
    by(auto dest!: bisim1_Invoke_stkD)
  with stk @ [v1] = rev vs @ Addr a # stk' obtain stk'''
    where stk''': "stk = rev vs @ Addr a # stk'''" and stk: "stk' = stk''' @ [v1]"
    by(cases stk' rule: rev_cases) auto
  from n + max_vars (Val v1 «bop» e')  length xs have "n + max_vars e'  length xs" by simp
  moreover from ‹bsok (e1 «bop» e2) n have "bsok e2 n" by simp
  ultimately have "?concl e' xs e2 n pc stk''' loc" using stk''' by-(rule IH)
  then obtain e'' xs' where IH': "τred1r P t h (e', xs) (e'', xs')" "call1 e'' = (a, M, vs)"
    and bisim: "P,e2,h  (e'', xs')  (rev vs @ Addr a # stk''', loc, pc, None)" by blast
  from bisim have "P,e1«bop»e2,h  (Val v1 «bop» e'', xs')  ((rev vs @ Addr a # stk''') @ [v1], loc, length (compE2 e1) + pc, None)"
    by(rule bisim1_bisims1.bisim1BinOp2)
  with IH' stk show ?case by(fastforce elim!: BinOp_τred1r_xt2)
next
  case bisim1LAss1 thus ?case
    by(fastforce split: if_split_asm intro: bisim1_bisims1.bisim1LAss1 dest: bisim1_pc_length_compE2 elim!: LAss_τred1r)
next
  case bisim1LAss2 thus ?case by simp
next
  case bisim1AAcc1 thus ?case
    apply(auto split: if_split_asm intro: bisim1_bisims1.bisim1AAcc1 dest: bisim1_pc_length_compE2 elim!: AAcc_τred1r_xt1)
    apply(fastforce elim!: AAcc_τred1r_xt1 intro: bisim1_bisims1.bisim1AAcc1)
    done
next
  case (bisim1AAcc2 e2 n e' xs stk loc pc e1 v1)
  note IH = stk'. stk = rev vs @ Addr a # stk'; pc < length (compE2 e2); compE2 e2 ! pc = Invoke M (length vs); n + max_vars e'  length xs; bsok e2 n
                        ?concl e' xs e2 n pc stk' loc
  note inv = ‹compE2 (e1e2) ! (length (compE2 e1) + pc) = Invoke M (length vs)
  with ‹length (compE2 e1) + pc < length (compE2 (e1e2)) have pc: "pc < length (compE2 e2)"
    by(auto split: if_split_asm)
  moreover with inv have "compE2 e2 ! pc = Invoke M (length vs)" by simp
  moreover with P,e2,h  (e', xs)  (stk, loc, pc, None) pc
  obtain vs'' v'' stk'' where "stk = vs'' @ v'' # stk''" and "length vs'' = length vs"
    by(auto dest!: bisim1_Invoke_stkD)
  with stk @ [v1] = rev vs @ Addr a # stk' obtain stk'''
    where stk''': "stk = rev vs @ Addr a # stk'''" and stk: "stk' = stk''' @ [v1]"
    by(cases stk' rule: rev_cases) auto
  from n + max_vars (Val v1e')  length xs have "n + max_vars e'  length xs" by simp
  moreover from ‹bsok (e1e2) n have "bsok e2 n" by simp
  ultimately have "?concl e' xs e2 n pc stk''' loc" using stk''' by-(rule IH)
  then obtain e'' xs' where IH': "τred1r P t h (e', xs) (e'', xs')" "call1 e'' = (a, M, vs)"
    and bisim: "P,e2,h  (e'', xs')  (rev vs @ Addr a # stk''', loc, pc, None)" by blast
  from bisim have "P,e1e2,h  (Val v1e'', xs')  ((rev vs @ Addr a # stk''') @ [v1], loc, length (compE2 e1) + pc, None)"
    by(rule bisim1_bisims1.bisim1AAcc2)
  with IH' stk show ?case by(fastforce elim!: AAcc_τred1r_xt2)
next
  case (bisim1AAss1 e n e' xs loc pc e2 e3)
  note IH =  pc < length (compE2 e); compE2 e ! pc = Invoke M (length vs); n + max_vars e'  length xs; bsok e n
               ?concl e' xs e n pc stk' loc
  note bisim = P,e,h  (e', xs)  (rev vs @ Addr a # stk', loc, pc, None)
  note len = n + max_vars (e'e2 := e3)  length xs
  hence len': "n + max_vars e'  length xs" by simp
  note inv = ‹compE2 (ee2 := e3) ! pc = Invoke M (length vs)
  with pc < length (compE2 (ee2 := e3)) bisim have pc: "pc < length (compE2 e)"
    by(auto split: if_split_asm dest: bisim1_pc_length_compE2)
  moreover with inv have "compE2 e ! pc = Invoke M (length vs)" by simp
  moreover from ‹bsok (ee2 := e3) n have "bsok e n" by simp
  ultimately have "?concl e' xs e n pc stk' loc" using len' by-(rule IH)
  thus ?case
    by(fastforce intro: bisim1_bisims1.bisim1AAss1 elim!: AAss_τred1r_xt1)
next
  case (bisim1AAss2 e2 n e' xs stk loc pc e1 e3 v1)
  note IH = stk'. stk = rev vs @ Addr a # stk'; pc < length (compE2 e2); compE2 e2 ! pc = Invoke M (length vs); n + max_vars e'  length xs; bsok e2 n
                        ?concl e' xs e2 n pc stk' loc
  note inv = ‹compE2 (e1e2 := e3) ! (length (compE2 e1) + pc) = Invoke M (length vs)
  note bisim = P,e2,h  (e', xs)  (stk, loc, pc, None)
  with inv ‹length (compE2 e1) + pc < length (compE2 (e1e2 := e3)) have pc: "pc < length (compE2 e2)"
    by(auto split: if_split_asm dest: bisim1_pc_length_compE2)
  moreover with inv have "compE2 e2 ! pc = Invoke M (length vs)" by simp
  moreover with bisim pc
  obtain vs'' v'' stk'' where "stk = vs'' @ v'' # stk''" and "length vs'' = length vs"
    by(auto dest!: bisim1_Invoke_stkD)
  with stk @ [v1] = rev vs @ Addr a # stk' obtain stk'''
    where stk''': "stk = rev vs @ Addr a # stk'''" and stk: "stk' = stk''' @ [v1]"
    by(cases stk' rule: rev_cases) auto
  from n + max_vars (Val v1e' := e3)  length xs have "n + max_vars e'  length xs" by simp
  moreover from ‹bsok (e1e2 := e3) n have "bsok e2 n" by simp
  ultimately have "?concl e' xs e2 n pc stk''' loc" using stk''' by-(rule IH)
  then obtain e'' xs' where IH': "τred1r P t h (e', xs) (e'', xs')" "call1 e'' = (a, M, vs)"
    and bisim: "P,e2,h  (e'', xs')  (rev vs @ Addr a # stk''', loc, pc, None)" by blast
  from bisim
  have "P,e1e2 := e3,h  (Val v1e'' := e3, xs')  ((rev vs @ Addr a # stk''') @ [v1], loc, length (compE2 e1) + pc, None)"
    by(rule bisim1_bisims1.bisim1AAss2)
  with IH' stk show ?case by(fastforce elim!: AAss_τred1r_xt2)
next
  case (bisim1AAss3 e3 n e' xs stk loc pc e1 e2 v1 v2)
  note IH = stk'. stk = rev vs @ Addr a # stk'; pc < length (compE2 e3); compE2 e3 ! pc = Invoke M (length vs); n + max_vars e'  length xs; bsok e3 n
                        ?concl e' xs e3 n pc stk' loc
  note inv = ‹compE2 (e1e2 := e3) ! (length (compE2 e1) + length (compE2 e2) + pc) = Invoke M (length vs)
  with ‹length (compE2 e1) + length (compE2 e2) + pc < length (compE2 (e1e2 := e3))
  have pc: "pc < length (compE2 e3)" by(simp add: nth_Cons split: nat.split_asm if_split_asm)
  moreover with inv have "compE2 e3 ! pc = Invoke M (length vs)" by simp
  moreover with P,e3,h  (e', xs)  (stk, loc, pc, None)  pc
  obtain vs'' v'' stk'' where "stk = vs'' @ v'' # stk''" and "length vs'' = length vs"
    by(auto dest!: bisim1_Invoke_stkD)
  with stk @ [v2, v1] = rev vs @ Addr a # stk' obtain stk'''
    where stk''': "stk = rev vs @ Addr a # stk'''" and stk: "stk' = stk''' @ [v2, v1]"
    by(cases stk' rule: rev_cases) auto
  from n + max_vars (Val v1Val v2 := e')  length xs have "n + max_vars e'  length xs" by simp
  moreover from ‹bsok (e1e2 := e3) n have "bsok e3 n" by simp
  ultimately have "?concl e' xs e3 n pc stk''' loc" using stk''' by-(rule IH)
  then obtain e'' xs' where IH': "τred1r P t h (e', xs) (e'', xs')" "call1 e'' = (a, M, vs)"
    and bisim: "P,e3,h  (e'', xs')  (rev vs @ Addr a # stk''', loc, pc, None)" by blast
  from bisim
  have "P,e1e2 := e3,h  (Val v1Val v2 := e'', xs')  ((rev vs @ Addr a # stk''') @ [v2, v1], loc, length (compE2 e1) + length (compE2 e2) + pc, None)"
    by -(rule bisim1_bisims1.bisim1AAss3, auto)
  with IH' stk show ?case by(fastforce elim!: AAss_τred1r_xt3)
next
  case bisim1AAss4 thus ?case by simp
next
  case bisim1ALength thus ?case
    by(fastforce split: if_split_asm intro: bisim1_bisims1.bisim1ALength dest: bisim1_pc_length_compE2 elim!: ALength_τred1r_xt)
next
  case bisim1FAcc thus ?case
    by(fastforce split: if_split_asm intro: bisim1_bisims1.bisim1FAcc dest: bisim1_pc_length_compE2 elim!: FAcc_τred1r_xt)
next
  case bisim1FAss1 thus ?case
    apply(auto split: if_split_asm intro: bisim1_bisims1.bisim1FAss1 dest: bisim1_pc_length_compE2 elim!: FAss_τred1r_xt1)
    by(fastforce intro: bisim1_bisims1.bisim1FAss1 elim!: FAss_τred1r_xt1)
next
  case (bisim1FAss2 e2 n e' xs stk loc pc e1 F D v1)
  note IH = stk'. stk = rev vs @ Addr a # stk'; pc < length (compE2 e2); compE2 e2 ! pc = Invoke M (length vs); n + max_vars e'  length xs; bsok e2 n
                        ?concl e' xs e2 n pc stk' loc
  note inv = ‹compE2 (e1F{D} := e2) ! (length (compE2 e1) + pc) = Invoke M (length vs)
  with ‹length (compE2 e1) + pc < length (compE2 (e1F{D} := e2)) have pc: "pc < length (compE2 e2)"
    by(simp split: if_split_asm nat.split_asm add: nth_Cons)
  moreover with inv have "compE2 e2 ! pc = Invoke M (length vs)" by simp
  moreover with P,e2,h  (e', xs)  (stk, loc, pc, None) pc
  obtain vs'' v'' stk'' where "stk = vs'' @ v'' # stk''" and "length vs'' = length vs"
    by(auto dest!: bisim1_Invoke_stkD)
  with stk @ [v1] = rev vs @ Addr a # stk' obtain stk'''
    where stk''': "stk = rev vs @ Addr a # stk'''" and stk: "stk' = stk''' @ [v1]"
    by(cases stk' rule: rev_cases) auto
  from n + max_vars (Val v1F{D} := e')  length xs have "n + max_vars e'  length xs" by simp
  moreover from ‹bsok (e1F{D} := e2) n have "bsok e2 n" by simp
  ultimately have "?concl e' xs e2 n pc stk''' loc" using stk''' by-(rule IH)
  then obtain e'' xs' where IH': "τred1r P t h (e', xs) (e'', xs')" "call1 e'' = (a, M, vs)"
    and bisim: "P,e2,h  (e'', xs')  (rev vs @ Addr a # stk''', loc, pc, None)" by blast
  from bisim have "P,e1F{D} := e2,h  (Val v1F{D} := e'', xs')  ((rev vs @ Addr a # stk''') @ [v1], loc, length (compE2 e1) + pc, None)"
    by(rule bisim1_bisims1.bisim1FAss2)
  with IH' stk show ?case by(fastforce elim!: FAss_τred1r_xt2)
next
  case bisim1FAss3 thus ?case by simp
next
  case (bisim1CAS1 e n e' xs loc pc e2 e3 D F)
  note IH =  pc < length (compE2 e); compE2 e ! pc = Invoke M (length vs); n + max_vars e'  length xs; bsok e n
               ?concl e' xs e n pc stk' loc
  note bisim = P,e,h  (e', xs)  (rev vs @ Addr a # stk', loc, pc, None)
  note len = n + max_vars _  length xs
  hence len': "n + max_vars e'  length xs" by simp
  note inv = ‹compE2 _ ! pc = Invoke M (length vs)
  with pc < length _ bisim have pc: "pc < length (compE2 e)"
    by(auto split: if_split_asm dest: bisim1_pc_length_compE2)
  moreover with inv have "compE2 e ! pc = Invoke M (length vs)" by simp
  moreover from ‹bsok _ n have "bsok e n" by simp
  ultimately have "?concl e' xs e n pc stk' loc" using len' by-(rule IH)
  thus ?case
    by(fastforce intro: bisim1_bisims1.bisim1CAS1 elim!: CAS_τred1r_xt1)
next
  case (bisim1CAS2 e2 n e' xs stk loc pc e1 e3 D F v1)
  note IH = stk'. stk = rev vs @ Addr a # stk'; pc < length (compE2 e2); compE2 e2 ! pc = Invoke M (length vs); n + max_vars e'  length xs; bsok e2 n
                        ?concl e' xs e2 n pc stk' loc
  note inv = ‹compE2 _ ! (length (compE2 e1) + pc) = Invoke M (length vs)
  note bisim = P,e2,h  (e', xs)  (stk, loc, pc, None)
  with inv ‹length (compE2 e1) + pc < length (compE2 _) have pc: "pc < length (compE2 e2)"
    by(auto split: if_split_asm dest: bisim1_pc_length_compE2)
  moreover with inv have "compE2 e2 ! pc = Invoke M (length vs)" by simp
  moreover with bisim pc
  obtain vs'' v'' stk'' where "stk = vs'' @ v'' # stk''" and "length vs'' = length vs"
    by(auto dest!: bisim1_Invoke_stkD)
  with stk @ [v1] = rev vs @ Addr a # stk' obtain stk'''
    where stk''': "stk = rev vs @ Addr a # stk'''" and stk: "stk' = stk''' @ [v1]"
    by(cases stk' rule: rev_cases) auto
  from n + max_vars _  length xs have "n + max_vars e'  length xs" by simp
  moreover from ‹bsok _ n have "bsok e2 n" by simp
  ultimately have "?concl e' xs e2 n pc stk''' loc" using stk''' by-(rule IH)
  then obtain e'' xs' where IH': "τred1r P t h (e', xs) (e'', xs')" "call1 e'' = (a, M, vs)"
    and bisim: "P,e2,h  (e'', xs')  (rev vs @ Addr a # stk''', loc, pc, None)" by blast
  from bisim
  have "P,e1∙compareAndSwap(DF, e2, e3),h  (Val v1∙compareAndSwap(DF, e'', e3), xs')  ((rev vs @ Addr a # stk''') @ [v1], loc, length (compE2 e1) + pc, None)"
    by(rule bisim1_bisims1.bisim1CAS2)
  with IH' stk show ?case by(fastforce elim!: CAS_τred1r_xt2)
next
  case (bisim1CAS3 e3 n e' xs stk loc pc e1 e2 D F v1 v2)
  note IH = stk'. stk = rev vs @ Addr a # stk'; pc < length (compE2 e3); compE2 e3 ! pc = Invoke M (length vs); n + max_vars e'  length xs; bsok e3 n
                        ?concl e' xs e3 n pc stk' loc
  note inv = ‹compE2 _ ! (length (compE2 e1) + length (compE2 e2) + pc) = Invoke M (length vs)
  with ‹length (compE2 e1) + length (compE2 e2) + pc < length (compE2 _)
  have pc: "pc < length (compE2 e3)" by(simp add: nth_Cons split: nat.split_asm if_split_asm)
  moreover with inv have "compE2 e3 ! pc = Invoke M (length vs)" by simp
  moreover with P,e3,h  (e', xs)  (stk, loc, pc, None)  pc
  obtain vs'' v'' stk'' where "stk = vs'' @ v'' # stk''" and "length vs'' = length vs"
    by(auto dest!: bisim1_Invoke_stkD)
  with stk @ [v2, v1] = rev vs @ Addr a # stk' obtain stk'''
    where stk''': "stk = rev vs @ Addr a # stk'''" and stk: "stk' = stk''' @ [v2, v1]"
    by(cases stk' rule: rev_cases) auto
  from n + max_vars _  length xs have "n + max_vars e'  length xs" by simp
  moreover from ‹bsok _ n have "bsok e3 n" by simp
  ultimately have "?concl e' xs e3 n pc stk''' loc" using stk''' by-(rule IH)
  then obtain e'' xs' where IH': "τred1r P t h (e', xs) (e'', xs')" "call1 e'' = (a, M, vs)"
    and bisim: "P,e3,h  (e'', xs')  (rev vs @ Addr a # stk''', loc, pc, None)" by blast
  from bisim
  have "P,e1∙compareAndSwap(DF, e2, e3), h  (Val v1∙compareAndSwap(DF, Val v2, e''), xs')  ((rev vs @ Addr a # stk''') @ [v2, v1], loc, length (compE2 e1) + length (compE2 e2) + pc, None)"
    by -(rule bisim1_bisims1.bisim1CAS3, auto)
  with IH' stk show ?case by(fastforce elim!: CAS_τred1r_xt3)
next
  case (bisim1Call1 obj n obj' xs loc pc ps M')
  note IH = pc < length (compE2 obj); compE2 obj ! pc = Invoke M (length vs); n + max_vars obj'  length xs; bsok obj n
                       ?concl obj' xs obj n pc stk' loc
  note bisim = P,obj,h  (obj', xs)  (rev vs @ Addr a # stk', loc, pc, None)
  note len = n + max_vars (obj'M'(ps))  length xs
  hence len': "n + max_vars obj'  length xs" by simp
  from ‹bsok (objM'(ps)) n have bsok: "bsok obj n" by simp
  note inv = ‹compE2 (objM'(ps)) ! pc = Invoke M (length vs)
  with pc < length (compE2 (objM'(ps))) bisim
  have pc: "pc < length (compE2 obj)  ps = []  pc = length (compE2 obj)"
    by(cases ps)(auto split: if_split_asm dest: bisim1_pc_length_compE2)
  thus ?case
  proof
    assume "pc < length (compE2 obj)"
    moreover with inv have "compE2 obj ! pc = Invoke M (length vs)" by simp
    ultimately have "?concl obj' xs obj n pc stk' loc" using len' bsok by(rule IH)
    thus ?thesis by(fastforce intro: bisim1_bisims1.bisim1Call1 elim!: Call_τred1r_obj)
  next
    assume [simp]: "ps = []  pc = length (compE2 obj)"
    with inv have [simp]: "vs = []" "M' = M" by simp_all
    with bisim have [simp]: "vs = []" "stk' = []" by(auto dest: bisim1_pc_length_compE2D)
    with bisim len' bsok have "τred1r P t h (obj', xs) (addr a, loc)"
      by(auto intro: bisim1_Val_τred1r simp add: bsok_def)
    moreover
    have "P,objM([]),h  (addr aM([]), loc)  ([Addr a], loc, length (compE2 obj), None)"
      by(rule bisim1_bisims1.bisim1Call1[OF bisim1Val2]) simp_all
    ultimately show ?thesis by auto(fastforce elim!: Call_τred1r_obj)
  qed
next
  case (bisim1CallParams ps n ps' xs stk loc pc obj M' v)
  note IH = stk'. stk = rev vs @ Addr a # stk'; pc < length (compEs2 ps); compEs2 ps ! pc = Invoke M (length vs); n + max_varss ps'  length xs; bsoks ps n
                       ?concls ps' xs ps n pc stk' loc
  note bisim = P,ps,h  (ps', xs) [↔] (stk, loc, pc, None)
  note len = n + max_vars (Val vM'(ps'))  length xs
  hence len': "n + max_varss ps'  length xs" by simp
  note stk = stk @ [v] = rev vs @ Addr a # stk'
  note inv = ‹compE2 (objM'(ps)) ! (length (compE2 obj) + pc) = Invoke M (length vs)
  from ‹bsok (objM'(ps)) n have bsok: "bsoks ps n" by simp
  from ‹length (compE2 obj) + pc < length (compE2 (objM'(ps))) 
  have "pc < length (compEs2 ps)  pc = length (compEs2 ps)" by(auto)
  thus ?case
  proof
    assume pc: "pc < length (compEs2 ps)"
    moreover with inv have "compEs2 ps ! pc = Invoke M (length vs)" by simp
    moreover with bisim pc
    obtain vs'' v'' stk'' where "stk = vs'' @ v'' # stk''" and "length vs'' = length vs"
      by(auto dest!: bisims1_Invoke_stkD)
    with stk @ [v] = rev vs @ Addr a # stk' obtain stk'''
      where stk''': "stk = rev vs @ Addr a # stk'''" and stk: "stk' = stk''' @ [v]"
      by(cases stk' rule: rev_cases) auto
    note len' stk'''
    ultimately have "?concls ps' xs ps n pc stk''' loc" using bsok by-(rule IH)
    then obtain es'' xs' where IH': "τreds1r P t h (ps', xs) (es'', xs')" "calls1 es'' = (a, M, vs)"
      and bisim: "P,ps,h  (es'', xs') [↔] (rev vs @ Addr a # stk''', loc, pc, None)" by blast
    from bisim have "P,objM'(ps),h  (Val vM'(es''), xs')  ((rev vs @ Addr a # stk''') @ [v], loc, length (compE2 obj) + pc, None)"
      by(rule bisim1_bisims1.bisim1CallParams)
    with IH' stk show ?case
      by(fastforce elim!: Call_τred1r_param simp add: is_vals_conv)
  next
    assume [simp]: "pc = length (compEs2 ps)"
    from bisim obtain vs' where [simp]: "stk = rev vs'"
      and psvs': "length ps = length vs'" by(auto dest: bisims1_pc_length_compEs2D)
    from inv have [simp]: "M' = M" and vsps: "length vs = length ps" by simp_all
    with stk psvs' have [simp]: "v = Addr a" "stk' = []" "vs' = vs" by simp_all
    from bisim len' bsok have "τreds1r P t h (ps', xs) (map Val vs, loc)"
      by(auto intro: bisims1_Val_τReds1r simp add: bsoks_def)
    moreover from bisims1_map_Val_append[OF bisims1Nil vsps[symmetric], simplified, of P h loc]
    have "P,objM(ps),h  (addr aM(map Val vs), loc)  (rev vs @ [Addr a], loc, length (compE2 obj) + length (compEs2 ps), None)"
      by(rule bisim1_bisims1.bisim1CallParams)
    ultimately show ?thesis by(fastforce elim!: Call_τred1r_param)
  qed
next
  case bisim1BlockSome1 thus ?case by simp
next
  case bisim1BlockSome2 thus ?case by simp
next
  case (bisim1BlockSome4 e n e' xs loc pc V T v)
  note IH = pc < length (compE2 e); compE2 e ! pc = Invoke M (length vs); Suc n + max_vars e'  length xs; bsok e (Suc n)
               ?concl e' xs e (Suc V) pc stk' loc
  from ‹Suc (Suc pc) < length (compE2 {V:T=v; e}) have "pc < length (compE2 e)" by simp
  moreover from ‹compE2 {V:T=v; e} ! Suc (Suc pc) = Invoke M (length vs)
  have "compE2 e ! pc = Invoke M (length vs)" by simp
  moreover note len = n + max_vars {V:T=None; e'}  length xs
  hence "Suc n + max_vars e'  length xs" by simp
  moreover from ‹bsok {V:T=v; e} n have "bsok e (Suc n)" by simp
  ultimately have "?concl e' xs e (Suc V) pc stk' loc" by(rule IH)
  then obtain e'' xs' where red: "τred1r P t h (e', xs) (e'', xs')"
    and bisim': "P,e,h  (e'', xs')  (rev vs @ Addr a # stk', loc, pc, None)"
    and call: "call1 e'' = (a, M, vs)" by blast
  from red have "τred1r P t h ({V:T=None; e'}, xs) ({V:T=None; e''}, xs')" by(rule Block_None_τred1r_xt)
  with bisim' call show ?case by(fastforce intro: bisim1_bisims1.bisim1BlockSome4)
next
  case (bisim1BlockNone e n e' xs loc pc V T)
  note IH = pc < length (compE2 e); compE2 e ! pc = Invoke M (length vs); Suc n + max_vars e'  length xs; bsok e (Suc n)
                ?concl e' xs e (Suc V) pc stk' loc
  from pc < length (compE2 {V:T=None; e}) have "pc < length (compE2 e)" by simp
  moreover from ‹compE2 {V:T=None; e} ! pc = Invoke M (length vs)
  have "compE2 e ! pc = Invoke M (length vs)" by simp
  moreover note len = n + max_vars {V:T=None; e'}  length xs
  hence "Suc n + max_vars e'  length xs" by simp
  moreover from ‹bsok {V:T=None; e} n have "bsok e (Suc n)" by simp
  ultimately have "?concl e' xs e (Suc V) pc stk' loc" by(rule IH)
  then obtain e'' xs' where red: "τred1r P t h (e', xs) (e'', xs')"
    and bisim': "P,e,h  (e'', xs')  (rev vs @ Addr a # stk', loc, pc, None)"
    and call: "call1 e'' = (a, M, vs)" by blast
  from red have "τred1r P t h ({V:T=None; e'}, xs) ({V:T=None; e''}, xs')" by(rule Block_None_τred1r_xt)
  with bisim' call show ?case by(fastforce intro: bisim1_bisims1.bisim1BlockNone)
next
  case bisim1Sync1 thus ?case
    apply(auto split: if_split_asm intro: bisim1_bisims1.bisim1Sync1 dest: bisim1_pc_length_compE2 elim!: Sync_τred1r_xt)
    by(fastforce split: if_split_asm intro: bisim1_bisims1.bisim1Sync1 elim!: Sync_τred1r_xt)
next
  case bisim1Sync2 thus ?case by simp
next
  case bisim1Sync3 thus ?case by simp
next
  case bisim1Sync4 thus ?case
    apply(auto split: if_split_asm intro: bisim1_bisims1.bisim1Sync4 dest: bisim1_pc_length_compE2 elim!: InSync_τred1r_xt)
    by(fastforce split: if_split_asm intro: bisim1_bisims1.bisim1Sync4 elim!: InSync_τred1r_xt)
next
  case bisim1Sync5 thus ?case by simp
next
  case bisim1Sync6 thus ?case by simp
next
  case bisim1Sync7 thus ?case by simp
next
  case bisim1Sync8 thus ?case by simp
next
  case bisim1Sync9 thus ?case by simp
next
  case bisim1InSync thus ?case by simp
next
  case bisim1Seq1 thus ?case
    apply(auto split: if_split_asm intro: bisim1_bisims1.bisim1Seq1 dest: bisim1_pc_length_compE2 elim!: Seq_τred1r_xt)
    by(fastforce split: if_split_asm intro: bisim1_bisims1.bisim1Seq1 elim!: Seq_τred1r_xt)
next
  case bisim1Seq2 thus ?case
    by(auto split: if_split_asm intro: bisim1_bisims1.bisim1Seq2 dest: bisim1_pc_length_compE2)
next
  case bisim1Cond1 thus ?case
    apply(clarsimp split: if_split_asm)
     apply(fastforce intro!: exI intro: bisim1_bisims1.bisim1Cond1 elim!: Cond_τred1r_xt)
    by(fastforce dest: bisim1_pc_length_compE2)
next
  case bisim1CondThen thus ?case
    apply(clarsimp split: if_split_asm)
     apply(fastforce intro!: exI intro: bisim1_bisims1.bisim1CondThen)
    by(fastforce dest: bisim1_pc_length_compE2)
next
  case bisim1CondElse thus ?case
    by(clarsimp split: if_split_asm)(fastforce intro!: exI intro: bisim1_bisims1.bisim1CondElse)
next
  case bisim1While1 thus ?case by simp
next
  case bisim1While3 thus ?case
    apply(auto split: if_split_asm intro: bisim1_bisims1.bisim1While3 dest: bisim1_pc_length_compE2 elim!: Cond_τred1r_xt)
    by(fastforce split: if_split_asm intro: bisim1_bisims1.bisim1While3 elim!: Cond_τred1r_xt)
next
  case bisim1While4 thus ?case
    apply(auto split: if_split_asm intro: bisim1_bisims1.bisim1While4 dest: bisim1_pc_length_compE2 elim!: Seq_τred1r_xt)
    by(fastforce split: if_split_asm intro: bisim1_bisims1.bisim1While4 elim!: Seq_τred1r_xt)
next
  case bisim1While6 thus ?case by simp
next
  case bisim1While7 thus ?case by simp
next
  case bisim1Throw1 thus ?case
    by(fastforce split: if_split_asm intro: bisim1_bisims1.bisim1Throw1 dest: bisim1_pc_length_compE2 elim!: Throw_τred1r_xt)
next
  case bisim1Try thus ?case
    apply(auto split: if_split_asm intro: bisim1_bisims1.bisim1Try dest: bisim1_pc_length_compE2 elim!: Try_τred1r_xt)
    by(fastforce split: if_split_asm intro: bisim1_bisims1.bisim1Try elim!: Try_τred1r_xt)
next
  case bisim1TryCatch1 thus ?case by simp
next
  case (bisim1TryCatch2 e n e' xs loc pc e1 C V)
  note IH = pc < length (compE2 e); compE2 e ! pc = Invoke M (length vs); Suc n + max_vars e'  length xs; bsok e (Suc n)
               ?concl e' xs e (Suc V) pc stk' loc
  from ‹Suc (Suc (length (compE2 e1) + pc)) < length (compE2 (try e1 catch(C V) e))
  have "pc < length (compE2 e)" by simp
  moreover from ‹compE2 (try e1 catch(C V) e) ! Suc (Suc (length (compE2 e1) + pc)) = Invoke M (length vs)
  have "compE2 e ! pc = Invoke M (length vs)" by simp
  moreover note len = n + max_vars {V:Class C=None; e'}  length xs
  hence "Suc n + max_vars e'  length xs" by simp
  moreover from ‹bsok (try e1 catch(C V) e) n have "bsok e (Suc n)" by simp
  ultimately have "?concl e' xs e (Suc V) pc stk' loc" by(rule IH)
  then obtain e'' xs' where red: "τred1r P t h (e', xs) (e'', xs')"
    and bisim': "P,e,h  (e'', xs')  (rev vs @ Addr a # stk', loc, pc, None)"
    and call: "call1 e'' = (a, M, vs)" by blast
  from red have "τred1r P t h ({V:Class C=None; e'}, xs) ({V:Class C=None; e''}, xs')" 
    by(rule Block_None_τred1r_xt)
  with bisim' call show ?case by(fastforce intro: bisim1_bisims1.bisim1TryCatch2)
next
  case bisims1Nil thus ?case by simp
next
  case (bisims1List1 e n e' xs loc pc es)
  note IH = pc < length (compE2 e); compE2 e ! pc = Invoke M (length vs); n + max_vars e'  length xs; bsok e n
               ?concl e' xs e n pc stk' loc
  note bisim = P,e,h  (e', xs)  (rev vs @ Addr a # stk', loc, pc, None)
  note len = n + max_varss (e' # es)  length xs
  hence len': "n + max_vars e'  length xs" by simp
  from ‹bsoks (e # es) n have bsok: "bsok e n" by simp
  note inv = ‹compEs2 (e # es) ! pc = Invoke M (length vs)
  with pc < length (compEs2 (e # es)) bisim have pc: "pc < length (compE2 e)"
    by(cases es)(auto split: if_split_asm dest: bisim1_pc_length_compE2)
  moreover with inv have "compE2 e ! pc = Invoke M (length vs)" by simp
  ultimately have "?concl e' xs e n pc stk' loc" using len' bsok by(rule IH)
  thus ?case by(fastforce intro: bisim1_bisims1.bisims1List1 elim!: τred1r_inj_τreds1r)
next
  case (bisims1List2 es n es' xs stk loc pc e v)
  note IH = stk'. stk = rev vs @ Addr a # stk'; pc < length (compEs2 es); compEs2 es ! pc = Invoke M (length vs); n + max_varss es'  length xs; bsoks es n
                       ?concls es' xs es n pc stk' loc
  note bisim = P,es,h  (es', xs) [↔] (stk, loc, pc, None)
  note len = n + max_varss (Val v # es')  length xs
  hence len': "n + max_varss es'  length xs" by simp
  from ‹bsoks (e # es) n have bsok: "bsoks es n" by simp
  note stk = stk @ [v] = rev vs @ Addr a # stk'
  note inv = ‹compEs2 (e # es) ! (length (compE2 e) + pc) = Invoke M (length vs)
  from ‹length (compE2 e) + pc < length (compEs2 (e # es)) have pc: "pc < length (compEs2 es)" by auto
  moreover with inv have "compEs2 es ! pc = Invoke M (length vs)" by simp
  moreover with bisim pc
  obtain vs'' v'' stk'' where "stk = vs'' @ v'' # stk''" and "length vs'' = length vs"
    by(auto dest!: bisims1_Invoke_stkD)
  with stk @ [v] = rev vs @ Addr a # stk' obtain stk'''
    where stk''': "stk = rev vs @ Addr a # stk'''" and stk: "stk' = stk''' @ [v]"
    by(cases stk' rule: rev_cases) auto
  note len' stk'''
  ultimately have "?concls es' xs es n pc stk''' loc" using bsok by-(rule IH)
  then obtain es'' xs' where red: "τreds1r P t h (es', xs) (es'', xs')"
    and call: "calls1 es'' = (a, M, vs)"
    and bisim: "P,es,h  (es'', xs') [↔] (rev vs @ Addr a # stk''', loc, pc, None)" by blast
  from bisim have "P,e#es,h  (Val v # es'', xs') [↔]
                                          ((rev vs @ Addr a # stk''') @ [v], loc, length (compE2 e) + pc, None)" 
    by(rule bisim1_bisims1.bisims1List2)
  moreover from red have "τreds1r P t h (Val v # es', xs) (Val v # es'', xs')" by(rule τreds1r_cons_τreds1r)
  ultimately show ?case using stk call by fastforce
qed

end

declare split_beta [simp del]

context J1_JVM_conf_read begin

lemma τRed1_simulates_exec_1_τ:
  assumes wf: "wf_J1_prog P"
  and exec: "exec_1_d (compP2 P) t (Normal (xcp, h, frs)) ta (Normal (xcp', h', frs'))"
  and bisim: "bisim1_list1 t h (e, xs) exs xcp frs"
  and τ: "τMove2 (compP2 P) (xcp, h, frs)"
  shows "h = h'  (e' xs' exs'. (if sim21_size (compP2 P) (xcp', frs') (xcp, frs) then τRed1r else τRed1t) P t h ((e, xs), exs) ((e', xs'), exs')  bisim1_list1 t h (e', xs') exs' xcp' frs')"
using bisim
proof(cases)
  case (bl1_Normal stk loc C M pc FRS Ts T body D)
  hence [simp]: "frs = (stk, loc, C, M, pc) # FRS"
    and conf: "compTP P  t: (xcp, h, (stk, loc, C, M, pc) # FRS) "
    and sees: "P  C sees M: TsT = body in D"
    and bisim: "P,blocks1 0 (Class D#Ts) body,h  (e, xs)  (stk, loc, pc, xcp)"
    and lenxs: "max_vars e  length xs"
    and bisims: "list_all2 (bisim1_fr P h) exs FRS" by auto
  from sees_method_compP[OF sees, where f="λC M Ts T. compMb2"]
  have sees': "compP2 P  C sees M: TsT = (max_stack body, max_vars body, compE2 body @ [Return], compxE2 body 0 0) in D"
    by(simp add: compP2_def compMb2_def)
  from bisim have pc: "pc  length (compE2 body)" by(auto dest: bisim1_pc_length_compE2)
  from conf have hconf: "hconf h" "preallocated h" by(simp_all add: correct_state_def)

  from sees wf have bsok: "bsok (blocks1 0 (Class D # Ts) body) 0"
    by(auto dest!: sees_wf_mdecl simp add: bsok_def wf_mdecl_def WT1_expr_locks)

  from exec obtain check: "check (compP2 P) (xcp, h, frs)"
    and exec: "compP2 P,t  (xcp, h, frs) -ta-jvm→ (xcp', h', frs')"
    by(rule jvmd_NormalE)(auto simp add: exec_1_iff)

  from wt_compTP_compP2[OF wf] exec conf
  have conf': "compTP P  t:(xcp', h', frs') " by(auto intro: BV_correct_1)

  from conf have tconf: "P,h  t √t" unfolding correct_state_def
    by(simp add: compP2_def tconf_def)

  show ?thesis
  proof(cases xcp)
    case [simp]: None
    from exec have execi: "(ta, xcp', h', frs')  exec_instr (instrs_of (compP2 P) C M ! pc) (compP2 P) t h stk loc C M pc FRS"
      by(simp add: exec_1_iff)
    show ?thesis
    proof(cases "pc < length (compE2 body)")
      case True
      with execi sees' have execi: "(ta, xcp', h', frs')  exec_instr (compE2 body ! pc) (compP2 P) t h stk loc C M pc FRS"
        by(simp)
      from τ sees' True have τi: "τmove2 (compP2 P) h stk body pc None" by(simp add: τmove2_iff)

      show ?thesis
      proof(cases "length frs' = Suc (length FRS)")
        case False
        with execi sees True compE2_not_Return[of body]
        have "(M n. compE2 body ! pc = Invoke M n)"
          apply(cases "compE2 body ! pc")
          apply(auto split: if_split_asm sum.split_asm simp add: split_beta compP2_def compMb2_def)
          apply(metis in_set_conv_nth)+
          done
        then obtain MM n where ins: "compE2 body ! pc = Invoke MM n" by blast
        with bisim1_Invoke_stkD[OF bisim[unfolded None], of MM n] True obtain vs' v' stk' 
          where [simp]: "stk = vs' @ v' # stk'" "n = length vs'" by auto
        from check sees True ins have "is_Ref v'"
          by(auto split: if_split_asm simp add: split_beta compP2_def compMb2_def check_def)
        moreover from execi sees True ins False sees' have "v'  Null" by auto
        ultimately obtain a' where [simp]: "v' = Addr a'" by(auto simp add: is_Ref_def)
        from bisim have Bisim': "P,blocks1 0 (Class D#Ts) body,h  (e, xs)  (rev (rev vs') @ Addr a' # stk', loc, pc, None)"
          by simp
        from bisim1_Invoke_τRed[OF this _ _ _ bsok, of MM t] True ins lenxs
        obtain e' xs' where red: "τred1r P t h (e, xs) (e', xs')"
          and bisim': "P,blocks1 0 (Class D#Ts) body,h  (e', xs')  (rev (rev vs') @ Addr a' # stk', loc, pc, None)"
          and call': "call1 e' = (a', MM, rev vs')" by auto
        from red have Red: "τRed1r P t h ((e, xs), exs) ((e', xs'), exs)"
          by(rule τred1r_into_τRed1r)
        
        from False execi True check ins sees' obtain U' Ts' T' meth D'
          where ha': "typeof_addr h a' = U'"
          and Sees': "compP2 P  class_type_of U' sees MM:Ts'  T' = meth in D'"
          by(auto simp add: check_def has_method_def split: if_split_asm)(auto split: extCallRet.split_asm)
        from sees_method_compPD[OF Sees'[unfolded compP2_def]] obtain body'
          where Sees: "P  class_type_of U' sees MM:Ts'  T'=body' in D'"
          and [simp]: "meth = (max_stack body', max_vars body', compE2 body' @ [Return], compxE2 body' 0 0)"
          by(auto simp add: compMb2_def)
        
        let ?e = "blocks1 0 (Class D'#Ts') body'"
        let ?xs = "Addr a' # rev vs' @ replicate (max_vars body') undefined_value"
        let ?e'xs' = "(e', xs')"
        let ?f = "(stk, loc, C, M, pc)"
        let ?f' = "([],Addr a' # rev vs' @ replicate (max_vars body') undefined_value, D', MM, 0)"
        
        from execi pc ins False ha' Sees' sees'
        have [simp]: "xcp' = None" "ta = ε" "frs' = ?f' # ?f # FRS" "h' = h"
          by(auto split: if_split_asm simp add: split_beta)
        
        from bisim' have bisim'': "P,blocks1 0 (Class D#Ts) body,h  (e', xs')  (rev (rev vs') @ Addr a' # stk', loc, pc, None)"
          by simp
        have "n = length vs'" by simp
        from conf' Sees' ins sees' True have "n = length Ts'"
          apply(auto simp add: correct_state_def)
          apply(drule (1) sees_method_fun)+
          apply(auto dest: sees_method_idemp sees_method_fun)
          done
        with n = length vs' have vs'Ts': "length (rev vs') = length Ts'" by simp
        
        with call' ha' Sees
        have "True,P,t ⊢1 (e', xs')/exs,h -ε (?e, ?xs)/ (e', xs') # exs, h" by(rule red1Call)
        hence "True,P,t ⊢1 (e', xs')/exs,h -ε (?e, ?xs)/ ?e'xs' # exs, h" by(simp)
        moreover from call' Sees ha' have "τMove1 P h ((e', xs'), exs)"
          by(auto simp add: synthesized_call_def dest!: τmove1_not_call1[where P=P and h=h] dest: sees_method_fun)
        ultimately have "τRed1t P t h ((e', xs'), exs) ((?e, ?xs), ?e'xs' # exs)" by auto
        moreover have "bisim1_list1 t h (?e, ?xs) (?e'xs' # exs) None (?f' # ?f # FRS)"
        proof
          from conf' show "compTP P  t:(None, h, ?f' # ?f # FRS) " by simp
          from Sees show "P  D' sees MM: Ts'T' = body' in D'" by(rule sees_method_idemp)
          show "P,blocks1 0 (Class D'#Ts') body',h  (blocks1 0 (Class D'#Ts') body', ?xs)  ([], Addr a' # rev vs' @ replicate (max_vars body') undefined_value, 0, None)"
            by(rule bisim1_refl)
          show "max_vars (blocks1 0 (Class D'#Ts') body')  length ?xs" using vs'Ts' by(simp add: blocks1_max_vars)
          from sees have "bisim1_fr P h ?e'xs' ?f"
          proof
            show "P,blocks1 0 (Class D#Ts) body,h  (e', xs')  (stk, loc, pc, None)"
              using bisim'' by simp
            from call' show "call1 e' = (a', MM, rev vs')" .
            from red have xs'xs: "length xs' = length xs" by(rule τred1r_preserves_len)
            with red lenxs show "max_vars e'  length xs'" by(auto dest: τred1r_max_vars)
          qed
          with bisims show "list_all2 (bisim1_fr P h) (?e'xs' # exs) (?f # FRS)" by simp
        qed
        ultimately show ?thesis using Red
          by auto(blast intro: rtranclp_trans rtranclp_tranclp_tranclp tranclp_into_rtranclp)+
      next
        case True
        note pc = pc < length (compE2 body)
        with execi True have "stk' loc' pc'. frs' = (stk', loc', C, M, pc') # FRS"
          by(cases "(compE2 body @ [Return]) ! pc")(auto split: if_split_asm sum.split_asm simp: split_beta, auto split: extCallRet.splits)
        then obtain stk' loc' pc' where [simp]: "frs' = (stk', loc', C, M, pc') # FRS" by blast
        from conf obtain ST where "compP2 P,h  stk [:≤] ST" by(auto simp add: correct_state_def conf_f_def2)
        hence ST: "P,h  stk [:≤] ST" by(rule List.list_all2_mono)(simp add: compP2_def)
        from execi sees pc check
        have exec': "exec_move_d P t (blocks1 0 (Class D#Ts) body) h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
          apply(auto simp add: compP2_def compMb2_def exec_move_def check_def exec_meth_instr split: if_split_asm sum.split_asm)
          apply(cases "compE2 body ! pc")
          apply(auto simp add: neq_Nil_conv split_beta split: if_split_asm sum.split_asm)
          apply(force split: extCallRet.split_asm)
          apply(cases "compE2 body ! pc", auto simp add: split_beta neq_Nil_conv split: if_split_asm sum.split_asm)
          done
        from red1_simulates_exec_instr[OF wf hconf tconf bisim this _ bsok ST] lenxs τi obtain e'' xs''
          where bisim': "P,blocks1 0 (Class D#Ts) body,h'  (e'', xs'')  (stk', loc', pc', xcp')"
          and red: "(if xcp' = None  pc < pc' then τred1r else τred1t) P t h (e, xs) (e'', xs'')" and [simp]: "h' = h"
          by(auto simp del: blocks1.simps)
        have Red: "(if sim21_size (compP2 P) (xcp', frs') (xcp, frs) then τRed1r else τRed1t) P t h ((e, xs), exs) ((e'', xs''), exs)"
        proof(cases "xcp' = None  pc < pc'")
          case True
          from bisim bisim' have "pc  Suc (length (compE2 body))" "pc'  Suc (length (compE2 body))"
            by(auto dest: bisim1_pc_length_compE2)
          moreover {
            fix a assume "xcp' = a"
            with exec' have "pc = pc'" by(auto dest: exec_move_raise_xcp_pcD) }
          ultimately have "sim21_size (compP2 P) (xcp', frs') (xcp, frs)" using sees True 
            by(auto simp add: sim21_size_def)(auto simp add: compP2_def compMb2_def intro!: sim21_size_aux.intros)
          with red True show ?thesis by simp(rule τred1r_into_τRed1r)
        next
          case False
          thus ?thesis using red by(auto intro: τred1t_into_τRed1t τred1r_into_τRed1r)
        qed
        moreover from red lenxs
        have "max_vars e''  length xs''"
          apply(auto dest: τred1r_max_vars τred1r_preserves_len τred1t_max_vars τred1t_preserves_len split: if_split_asm)
          apply(frule τred1r_max_vars τred1t_max_vars, drule τred1r_preserves_len τred1t_preserves_len, simp)+
          done
        with conf' sees bisim'
        have "bisim1_list1 t h (e'', xs'') exs xcp' ((stk', loc', C, M, pc') # FRS)"
          unfolding frs' = (stk', loc', C, M, pc') # FRS h' = h
          using bisims by(rule bisim1_list1.bl1_Normal)
        ultimately show ?thesis by(auto split del: if_split)
      qed
    next
      case False
      with pc have [simp]: "pc = length (compE2 body)" by simp
      with execi sees have [simp]: "xcp' = None"
        by(cases "compE2 body ! pc")(auto split: if_split_asm simp add: compP2_def compMb2_def split_beta)
      from bisim have Bisim: "P,blocks1 0 (Class D#Ts) body,h  (e, xs)  (stk, loc, length (compE2 (blocks1 0 (Class D#Ts) body)), None)" by simp
      then obtain v where [simp]: "stk = [v]" by(blast dest: bisim1_pc_length_compE2D)
      with Bisim lenxs bsok have red: "τred1r P t h (e, xs) (Val v, loc)"
        by clarify (erule bisim1_Val_τred1r[where n=0], simp_all add: bsok_def)
      hence Red: "τRed1r P t h ((e, xs), exs) ((Val v, loc), exs)" by(rule τred1r_into_τRed1r)
      show ?thesis
      proof(cases "FRS")
        case [simp]: Nil
        with bisims have [simp]: "exs = []" by simp
        with exec sees' have [simp]: "ta = ε" "xcp' = None" "h' = h" "frs' = []"
          by(auto simp add: exec_1_iff)
        from hconf have "bisim1_list1 t h (Val v, loc) [] None []" by(rule bl1_finalVal)
        then show ?thesis using Red
          by(auto intro: rtranclp.rtrancl_into_rtrancl rtranclp_into_tranclp1 simp del: τRed1_conv simp add: sim21_size_def)
      next
        case (Cons f' FRS')
        then obtain stk'' loc'' C'' M'' pc''
          where [simp]: "FRS = (stk'', loc'', C'', M'', pc'') # FRS'" by(cases f') fastforce
        from bisims obtain e'' xs'' EXS' where [simp]: "exs = (e'', xs'') # EXS'"
          by(auto simp add: list_all2_Cons2)
        with bisims have "bisim1_fr P h (e'', xs'') (stk'', loc'', C'', M'', pc'')" by simp
        then obtain E'' Ts'' T'' body'' D'' a'' M''' vs''
          where [simp]: "e'' = E''"
          and sees'': "P  C'' sees M'':Ts''T'' = body'' in D''"
          and bisim'': "P,blocks1 0 (Class D''#Ts'') body'',h  (E'', xs'')  (stk'', loc'', pc'', None)"
          and call'': "call1 E'' =  (a'', M''', vs'')"
          and lenxs'': "max_vars E''  length xs''"
          by(cases) fastforce
        let ?ee' = "inline_call (Val v) E''"
        let ?e' = "?ee'"
        let ?xs' = "xs''"
          
        from bisim'' call'' have pc'': "pc'' < length (compE2 (blocks1 0 (Class D''#Ts'') body''))"
          by(rule bisim1_call_pcD)
        hence pc'': "pc'' < length (compE2 body'')" by simp
        with sees_method_compP[OF sees'', where f="λC M Ts T. compMb2"] 
          sees_method_compP[OF sees, where f="λC M Ts T. compMb2"] conf
        obtain ST LT where Φ: "compTP P C'' M'' ! pc'' = (ST, LT)"
          and conff: "conf_f (compP (λC M Ts T. compMb2) P) h (ST, LT) (compE2 body'' @ [Return]) (stk'', loc'', C'', M'', pc'')"
          and ins: "(compE2 body'' @ [Return]) ! pc'' = Invoke M (length Ts)"
          unfolding correct_state_def by(fastforce simp add: compP2_def compMb2_def dest: sees_method_fun)
        from bisim1_callD[OF bisim'' call'', of M "length Ts"] ins pc''
        have [simp]: "M''' = M" by simp
          
        from call'' have "call1 E'' = (a'', M''', vs'')" by simp
        have "True,P,t ⊢1 (Val v, loc)/(E'', xs'') # EXS',h -ε
                      (inline_call (Val v) E'', xs'')/EXS', h"
          by(rule red1Return) simp
        hence "True,P,t ⊢1 (Val v, loc)/(E'', xs'') # EXS',h -ε (?e', ?xs')/EXS', h"
          by simp
        moreover have "τMove1 P h ((Val v, loc), (E'', xs'') # EXS')" by auto
        ultimately have "τRed1 P t h ((Val v, loc), (E'', xs'') # EXS') ((?e', ?xs'), EXS')" by auto
        moreover from exec sees have [simp]: "ta = ε" "h' = h"
          and [simp]: "frs' = (v # drop (length Ts + 1) stk'', loc'', C'', M'', pc'' + 1) # FRS'"
          by(auto simp add: compP2_def compMb2_def exec_1_iff)
          
        have "bisim1_list1 t h (?e', ?xs') EXS' None ((v # drop (length Ts + 1) stk'', loc'', C'', M'', pc'' + 1) # FRS')"
        proof
          from conf' show "compTP P  t: (None, h, (v # drop (length Ts + 1) stk'', loc'', C'', M'', pc'' + 1) # FRS') " by simp
          from sees'' show "P  C'' sees M'': Ts''T'' = body'' in D''" .
          from bisim1_inline_call_Val[OF bisim'' call'', of "length Ts" v] ins pc''
          show "P,blocks1 0 (Class D''#Ts'') body'',h  (inline_call (Val v) E'', xs'')  (v # drop (length Ts + 1) stk'', loc'', pc'' + 1, None)" by simp
          from lenxs'' max_vars_inline_call[of "Val v" "E''"]
          show "max_vars (inline_call (Val v) E'')  length xs''" by simp
          from bisims show "list_all2 (bisim1_fr P h) EXS' FRS'" by simp
        qed
        ultimately show ?thesis using Red
          by(auto simp del: τRed1_conv intro: rtranclp_into_tranclp1 rtranclp.rtrancl_into_rtrancl)
      qed
    qed
  next
    case [simp]: (Some a')
    from exec have execs: "(xcp', h', frs') = exception_step (compP2 P) a' h (stk, loc, C, M, pc) FRS"
      and [simp]: "ta = ε" by(auto simp add: exec_1_iff)
    from conf have confxcp': "conf_xcp' P h xcp" 
      unfolding correct_state_def by(auto simp add: compP2_def)
    then obtain D' where ha': "typeof_addr h a' = Class_type D'" and subclsD': "P  D' * Throwable" by auto
    from bisim have pc: "pc < length (compE2 body)" by(auto dest: bisim1_xcp_pcD)
    show ?thesis
    proof(cases "match_ex_table (compP2 P) (cname_of h a') pc (ex_table_of (compP2 P) C M)")
      case None
      from bisim have pc: "pc < length (compE2 body)" by(auto dest: bisim1_xcp_pcD)
      with sees' None have match: "match_ex_table (compP2 P) (cname_of h a') pc (compxE2 body 0 0) = None"
        by(auto)
      with execs sees' have [simp]: "ta = ε" "xcp' = a'" "h' = h" "frs' = FRS" using match sees' by auto
      from conf obtain CCC where ha: "typeof_addr h a' = Class_type CCC" and subcls: "P  CCC * Throwable"
        unfolding correct_state_def by(auto simp add: conf_f_def2 compP2_def)
      from bisim1_xcp_τRed[OF ha subcls bisim[unfolded Some], of "λC M Ts T. compMb2"] match lenxs bsok
      have red: "τred1r P t h (e, xs) (Throw a', loc)"
        and b': "P,blocks1 0 (Class D#Ts) body,h  (Throw a', loc)  (stk, loc, pc, a')"
        by(auto simp add: compP2_def bsok_def)
      from red have Red: "τRed1r P t h ((e, xs), exs) ((Throw a', loc), exs)"
        by(rule τred1r_into_τRed1r)
      show ?thesis
      proof(cases "FRS")
        case (Cons f' FRS')
        then obtain stk'' loc'' C'' M'' pc''
          where [simp]: "FRS = (stk'', loc'', C'', M'', pc'') # FRS'" by(cases f') fastforce
        from bisims obtain e'' xs'' EXS' where [simp]: "exs = (e'', xs'') # EXS'" 
          by(auto simp add: list_all2_Cons2)
        with bisims have "bisim1_fr P h (e'', xs'') (stk'', loc'', C'', M'', pc'')" by simp
        then obtain E'' Ts'' T'' body'' D'' a'' M''' vs''
          where [simp]: "e'' = E''"
          and sees'': "P  C'' sees M'':Ts''T'' = body'' in D''"
          and bisim'': "P,blocks1 0 (Class D''#Ts'') body'',h  (E'', xs'')  (stk'', loc'', pc'', None)"
          and call'': "call1 E'' =  (a'', M''', vs'')"
          and lenxs'': "max_vars E''  length xs''"
          by(cases) fastforce
        let ?ee' = "inline_call (Throw a') E''"
        let ?e' = "?ee'"
        let ?xs' = "xs''"
          
        from bisim'' call'' have pc'': "pc'' < length (compE2 (blocks1 0 (Class D''#Ts'') body''))"
          by(rule bisim1_call_pcD)
        hence pc'': "pc'' < length (compE2 body'')" by simp
        with sees_method_compP[OF sees'', where f="λC M Ts T. compMb2"]
          sees_method_compP[OF sees, where f="λC M Ts T. compMb2"] conf
        obtain ST LT where Φ: "compTP P C'' M'' ! pc'' = (ST, LT)"
          and conff: "conf_f (compP (λC M Ts T. compMb2) P) h (ST, LT) (compE2 body'' @ [Return]) (stk'', loc'', C'', M'', pc'')"
          and ins: "(compE2 body'' @ [Return]) ! pc'' = Invoke M (length Ts)"
          unfolding correct_state_def
          by(fastforce simp add: compP2_def compMb2_def dest: sees_method_fun)
        from bisim1_callD[OF bisim'' call'', of M "length Ts"] ins pc''
        have [simp]: "M''' = M" by simp
        
        have "True,P,t ⊢1 (Throw a', loc)/(E'', xs'') # EXS',h -ε (inline_call (Throw a') E'', xs'')/EXS', h"
          by(rule red1Return) simp
        moreover have "τMove1 P h ((Throw a', loc), (E'', xs'') # EXS')" by fastforce
        ultimately have "τRed1 P t h ((Throw a', loc), (E'', xs'') # EXS') ((?e', ?xs'), EXS')" by simp
        moreover
        have "bisim1_list1 t h (?e', ?xs') EXS' a' ((stk'', loc'', C'', M'', pc'') # FRS')"
        proof
          from conf' show "compTP P  t: (a', h, (stk'', loc'', C'', M'', pc'') # FRS') " by simp
          from sees'' show "P  C'' sees M'': Ts''T'' = body'' in D''" .
          from bisim1_inline_call_Throw[OF bisim'' call'', of "length Ts" a'] ins pc''
          show "P,blocks1 0 (Class D''#Ts'') body'',h  (inline_call (Throw a') E'', xs'')  (stk'', loc'', pc'', a')"
            by simp
          from lenxs'' max_vars_inline_call[of "Throw a'" "E''"]
          show "max_vars (inline_call (Throw a') E'')  length xs''" by simp
          from bisims show "list_all2 (bisim1_fr P h) EXS' FRS'" by simp
        qed
        ultimately show ?thesis using Red
          by(auto simp del: τRed1_conv intro: rtranclp.rtrancl_into_rtrancl rtranclp_into_tranclp1)
      next
        case [simp]: Nil
        with bisims have [simp]: "exs = []" by simp
        from hconf have "bisim1_list1 t h (Throw a', loc) [] a' []" by(rule bl1_finalThrow)
        thus ?thesis using Red 
          by(auto simp del: τRed1_conv intro: rtranclp.rtrancl_into_rtrancl rtranclp_into_tranclp1 simp add: sim21_size_def)
      qed
    next
      case (Some pcd)
      then obtain pch d where match: "match_ex_table (compP2 P) (cname_of h a') pc (ex_table_of (compP2 P) C M) = (pch, d)"
        by(cases pcd) auto
      with τ sees' pc have τ': "τmove2 (compP2 P) h stk body pc a'" by(simp add: compP2_def compMb2_def τmove2_iff)
      from match execs have [simp]: "h' = h" "xcp' = None" 
        "frs' = (Addr a' # drop (length stk - d) stk, loc, C, M, pch) # FRS" by simp_all
      from bisim match sees'
      have "d  length stk" by(auto intro: bisim1_match_Some_stk_length simp add: compP2_def compMb2_def)
      with match sees'
      have execm: "exec_move_d P t (blocks1 0 (Class D#Ts) body) h (stk, loc, pc, a') ta h' (Addr a' # drop (length stk - d) stk, loc, pch, None)"
        by(auto simp add: exec_move_def exec_meth_xcpt)
      from conf obtain ST where "compP2 P,h  stk [:≤] ST" by(auto simp add: correct_state_def conf_f_def2)
      hence ST: "P,h  stk [:≤] ST" by(rule List.list_all2_mono)(simp add: compP2_def)
      from red1_simulates_exec_instr[OF wf hconf tconf bisim[unfolded xcp = a'] execm _ bsok ST] lenxs ha' subclsD' τ'
      obtain e'' xs''
        where b': "P,blocks1 0 (Class D#Ts) body,h  (e'', xs'')  (Addr a' # drop (length stk - d) stk, loc, pch, None)"
        and red: "(if pc < pch then τred1r else τred1t) P t h (e, xs) (e'', xs'')" and [simp]: "h' = h"
        by(auto split: if_split_asm intro: τmove2xcp simp add: compP2_def simp del: blocks1.simps)
      have Red: "(if sim21_size (compP2 P) (xcp', frs') (xcp, frs) then τRed1r else τRed1t) P t h ((e, xs), exs) ((e'', xs''), exs)"
      proof(cases "pc < pch")
        case True
        from bisim b' have "pc  Suc (length (compE2 body))" "pch  Suc (length (compE2 body))"
          by(auto dest: bisim1_pc_length_compE2)
        with sees True have "sim21_size (compP2 P) (xcp', frs') (xcp, frs)"
          by(auto simp add: sim21_size_def)(auto simp add: compP2_def compMb2_def intro: sim21_size_aux.intros)
        with red True show ?thesis by simp(rule τred1r_into_τRed1r)
      next
        case False
        thus ?thesis using red by(auto intro: τred1t_into_τRed1t τred1r_into_τRed1r)
      qed
      moreover from red lenxs
      have "max_vars e''  length xs''"
        apply(auto dest: τred1r_max_vars τred1r_preserves_len τred1t_max_vars τred1t_preserves_len split: if_split_asm)
        apply(frule τred1r_max_vars τred1t_max_vars, drule τred1r_preserves_len τred1t_preserves_len, simp)+
        done
      with conf' sees b'
      have "bisim1_list1 t h (e'', xs'') exs None ((Addr a' # drop (length stk - d) stk, loc, C, M, pch) # FRS)"
        using bisims unfolding h' = h xcp' = None›
          frs' = (Addr a' # drop (length stk - d) stk, loc, C, M, pch) # FRS
        by rule
      ultimately show ?thesis by(auto split del: if_split)
    qed
  qed
qed(insert exec, auto simp add: exec_1_iff elim!: jvmd_NormalE)

lemma τRed1_simulates_exec_1_not_τ:
  assumes wf: "wf_J1_prog P"
  and exec: "exec_1_d (compP2 P) t (Normal (xcp, h, frs)) ta (Normal (xcp', h', frs'))"
  and bisim: "bisim1_list1 t h (e, xs) exs xcp frs"
  and τ: "¬ τMove2 (compP2 P) (xcp, h, frs)"
  shows "e' xs' exs' ta' e'' xs'' exs''. τRed1r P t h ((e, xs), exs) ((e', xs'), exs') 
                                      True,P,t ⊢1 (e', xs')/exs', h -ta' (e'', xs'')/exs'', h' 
                                      ¬ τMove1 P h ((e', xs'), exs')  ta_bisim wbisim1 ta' ta 
                                      bisim1_list1 t h' (e'', xs'') exs'' xcp' frs'  
                                      (call1 e = None 
                                      (case frs of Nil  False | (stk, loc, C, M, pc) # FRS  M' n. instrs_of (compP2 P) C M ! pc  Invoke M' n) 
                                       e' = e  xs' = xs  exs' = exs)
"
using bisim
proof cases
  case (bl1_Normal stk loc C M pc FRS Ts T body D)
  hence [simp]: "frs = (stk, loc, C, M, pc) # FRS"
    and conf: "compTP P  t: (xcp, h, (stk, loc, C, M, pc) # FRS) "
    and sees: "P  C sees M: TsT = body in D"
    and bisim: "P,blocks1 0 (Class D#Ts) body,h  (e, xs)  (stk, loc, pc, xcp)"
    and lenxs: "max_vars e  length xs"
    and bisims: "list_all2 (bisim1_fr P h) exs FRS" by auto

  from sees_method_compP[OF sees, where f="λC M Ts T. compMb2"]
  have sees': "compP2 P  C sees M: TsT = (max_stack body, max_vars body, compE2 body @ [Return], compxE2 body 0 0) in D"
    by(simp add: compP2_def compMb2_def)
  from bisim have pc: "pc  length (compE2 body)" by(auto dest: bisim1_pc_length_compE2)
  from conf have hconf: "hconf h" "preallocated h" and tconf: "P,h  t √t"
    unfolding correct_state_def by(simp_all add: compP2_def tconf_def)

  from sees wf have bsok: "bsok (blocks1 0 (Class D # Ts) body) 0"
    by(auto dest!: sees_wf_mdecl simp add: bsok_def wf_mdecl_def WT1_expr_locks)

  from exec obtain check: "check (compP2 P) (xcp, h, frs)"
    and exec: "compP2 P,t  (xcp, h, frs) -ta-jvm→ (xcp', h', frs')"
    by(rule jvmd_NormalE)(auto simp add: exec_1_iff)

  from wt_compTP_compP2[OF wf] exec conf
  have conf': "compTP P  t: (xcp', h', frs') " by(auto intro: BV_correct_1)

  show ?thesis
  proof(cases xcp)
    case [simp]: None
    from exec have execi: "(ta, xcp', h', frs')  exec_instr (instrs_of (compP2 P) C M ! pc) (compP2 P) t h stk loc C M pc FRS"
      by(simp add: exec_1_iff)
    show ?thesis
    proof(cases "length frs' = Suc (length FRS)")
      case True
      with pc execi sees' have pc: "pc < length (compE2 body)"
        by(auto split: if_split_asm simp add: split_beta)
      with execi sees' have execi: "(ta, xcp', h', frs')  exec_instr (compE2 body ! pc) (compP2 P) t h stk loc C M pc FRS"
        by(simp)
      from τ sees' True pc have τi: "¬ τmove2 (compP2 P) h stk body pc None" by(simp add: τmove2_iff)
      from execi True sees' pc have "stk' loc' pc'. frs' = (stk', loc', C, M, pc') # FRS"
        by(cases "(compE2 body @ [Return]) ! pc")(auto split: if_split_asm sum.split_asm simp add: split_beta, auto split: extCallRet.splits)
      then obtain stk' loc' pc' where [simp]: "frs' = (stk', loc', C, M, pc') # FRS" by blast
      from conf obtain ST where "compP2 P,h  stk [:≤] ST" by(auto simp add: correct_state_def conf_f_def2)
      hence ST: "P,h  stk [:≤] ST" by(rule List.list_all2_mono)(simp add: compP2_def)
      from execi sees True check pc
      have exec': "exec_move_d P t (blocks1 0 (Class D#Ts) body) h (stk, loc, pc, xcp) ta h' (stk', loc', pc', xcp')"
        apply(auto simp add: compP2_def compMb2_def exec_move_def check_def exec_meth_instr split: if_split_asm sum.split_asm)
        apply(cases "compE2 body ! pc")
        apply(auto simp add: neq_Nil_conv split_beta split: if_split_asm sum.split_asm)
        apply(force split: extCallRet.split_asm)
        apply(cases "compE2 body ! pc", auto simp add: split_beta neq_Nil_conv split: if_split_asm sum.split_asm)
        done
      from red1_simulates_exec_instr[OF wf hconf tconf bisim this _ bsok ST] lenxs τi obtain e'' xs'' ta' e' xs'
        where bisim': "P,blocks1 0 (Class D#Ts) body,h'  (e'', xs'')  (stk', loc', pc', xcp')"
        and red1: "τred1r P t h (e, xs) (e', xs')" and red2: "True,P,t ⊢1 e',(h, xs') -ta' e'',(h', xs'')"
        and τ1: "¬ τmove1 P h e'" and tabisim: "ta_bisim wbisim1 (extTA2J1 P ta') ta" 
        and call: "call1 e = None  no_call2 (blocks1 0 (Class D # Ts) body) pc  e' = e  xs' = xs"
        by(fastforce simp del: blocks1.simps)
      from red1 have Red1: "τRed1r P t h ((e, xs), exs) ((e', xs'), exs)"
        by(rule τred1r_into_τRed1r)
      moreover from red2 have "True,P,t ⊢1 (e', xs')/exs, h -extTA2J1 P ta' (e'', xs'')/exs, h'"
        by(rule red1Red)
      moreover from τ1 red2 have "¬ τMove1 P h ((e', xs'), exs)" by auto
      moreover from τred1r_max_vars[OF red1] lenxs τred1r_preserves_len[OF red1]
      have "max_vars e'  length xs'" by simp
      with red1_preserves_len[OF red2] red1_max_vars[OF red2]
      have "max_vars e''  length xs''" by simp
      with conf' sees bisim'
      have "bisim1_list1 t h' (e'', xs'') exs xcp' ((stk', loc', C, M, pc') # FRS)"
        unfolding frs' = (stk', loc', C, M, pc') # FRS
      proof
        from red2 have "hext h h'" by(auto dest: red1_hext_incr)
        from bisims show "list_all2 (bisim1_fr P h') exs FRS"
          by(rule List.list_all2_mono)(erule bisim1_fr_hext_mono[OF _ ‹hext h h'])
      qed
      moreover from call sees'
      have "call1 e = None  (M' n. instrs_of (compP2 P) C M ! pc  Invoke M' n)  e' = e  xs' = xs"
        by(auto simp add: no_call2_def)
      ultimately show ?thesis using tabisim
        by(fastforce simp del: split_paired_Ex)
    next
      case False
      with execi sees pc compE2_not_Return[of body]
      have "(pc = length (compE2 body)  (M n. compE2 body ! pc = Invoke M n))  xcp' = None"
        apply(cases "compE2 body ! pc")
        apply(auto split: if_split_asm sum.split_asm simp add: split_beta compP2_def compMb2_def)
        apply(auto split: extCallRet.splits)
        apply(metis in_set_conv_nth)+
        done
      hence [simp]: "xcp' = None"
        and "pc = length (compE2 body)  (M n. compE2 body ! pc = Invoke M n)" by simp_all
      moreover
      { assume [simp]: "pc = length (compE2 body)"
        with sees_method_compP[OF sees, where f="λC M Ts T. compMb2"] τ have False by(auto simp add: compMb2_def compP2_def)
        hence ?thesis .. }
      moreover {
        assume "M n. compE2 body ! pc = Invoke M n"
          and "pc  length (compE2 body)"
        with pc obtain MM n where ins: "compE2 body ! pc = Invoke MM n"
          and pc: "pc < length (compE2 body)" by auto
        with bisim1_Invoke_stkD[OF bisim[unfolded None], of MM n] obtain vs' v' stk' 
          where [simp]: "stk = vs' @ v' # stk'" "n = length vs'" by auto
        with False τ sees' execi pc ins have False by auto (auto split: extCallRet.split_asm) }
      ultimately show ?thesis by blast
    qed
  next
    case [simp]: (Some ad)
    from bisim have pc: "pc < length (compE2 body)" by(auto dest: bisim1_xcp_pcD)
    with τ sees' have False by auto
    thus ?thesis ..
  qed
qed(insert exec, auto simp add: exec_1_iff elim!: jvmd_NormalE)

end

end

Theory Correctness2

(*  Title:      JinjaThreads/Compiler/Correctness2.thy
    Author:     Andreas Lochbihler
*)

section ‹Correctness of Stage 2: The multithreaded setting›

theory Correctness2
imports
  J1JVM
  JVMJ1
  "../BV/BVProgressThreaded"
begin

declare Listn.lesub_list_impl_same_size[simp del]

context J1_JVM_heap_conf_base begin

lemma bisim1_list1_has_methodD: "bisim1_list1 t h ex exs xcp ((stk, loc, C, M, pc) # frs)  P  C has M"
by(fastforce elim!: bisim1_list1.cases intro: has_methodI)

end

declare compP_has_method [simp]

sublocale J1_JVM_heap_conf_base < Red1_exec: 
  delay_bisimulation_base "mred1 P t" "mexec (compP2 P) t" "wbisim1 t" "ta_bisim wbisim1" "τMOVE1 P" "τMOVE2 (compP2 P)" 
  for t
.

sublocale J1_JVM_heap_conf_base < Red1_execd: delay_bisimulation_base
  "mred1 P t"
  "mexecd (compP2 P) t"
  "wbisim1 t"
  "ta_bisim wbisim1" 
  "τMOVE1 P"
  "τMOVE2 (compP2 P)" 
  for t
.

context JVM_heap_base begin

lemma τexec_1_d_silent_move:
  "τexec_1_d P t (xcp, h, frs) (xcp', h', frs')
   τtrsys.silent_move (mexecd P t) (τMOVE2 P) ((xcp, frs), h) ((xcp', frs'), h')"
apply(rule τtrsys.silent_move.intros)
apply auto
apply(rule exec_1_d_NormalI)
apply(auto simp add: exec_1_iff exec_d_def)
done

lemma silent_move_τexec_1_d:
  "τtrsys.silent_move (mexecd P t) (τMOVE2 P) ((xcp, frs), h) ((xcp', frs'), h')
   τexec_1_d P t (xcp, h, frs) (xcp', h', frs')"
apply(erule τtrsys.silent_move.cases)
apply clarsimp
apply(erule jvmd_NormalE)
apply(auto simp add: exec_1_iff)
done

lemma τExec_1_dr_rtranclpD:
  "τExec_1_dr P t (xcp, h, frs) (xcp', h', frs')
   τtrsys.silent_moves (mexecd P t) (τMOVE2 P) ((xcp, frs), h) ((xcp', frs'), h')"
by(induct rule: rtranclp_induct3)(blast intro: rtranclp.rtrancl_into_rtrancl τexec_1_d_silent_move)+

lemma τExec_1_dt_tranclpD:
  "τExec_1_dt P t (xcp, h, frs) (xcp', h', frs')
   τtrsys.silent_movet (mexecd P t) (τMOVE2 P) ((xcp, frs), h) ((xcp', frs'), h')"
by(induct rule: tranclp_induct3)(blast intro: tranclp.trancl_into_trancl τexec_1_d_silent_move)+

lemma rtranclp_τExec_1_dr:
  "τtrsys.silent_moves (mexecd P t) (τMOVE2 P) ((xcp, frs), h) ((xcp', frs'), h')
   τExec_1_dr P t (xcp, h, frs) (xcp', h', frs')"
by(induct rule: rtranclp_induct[of _ "((ax, ay), az)" "((bx, by), bz)", split_rule, consumes 1])(blast intro: rtranclp.rtrancl_into_rtrancl silent_move_τexec_1_d)+

lemma tranclp_τExec_1_dt:
  "τtrsys.silent_movet (mexecd P t) (τMOVE2 P) ((xcp, frs), h) ((xcp', frs'), h')
   τExec_1_dt P t (xcp, h, frs) (xcp', h', frs')"
by(induct rule: tranclp_induct[of _ "((ax, ay), az)" "((bx, by), bz)", split_rule, consumes 1])(blast intro: tranclp.trancl_into_trancl silent_move_τexec_1_d)+

lemma τExec_1_dr_conv_rtranclp:
  "τExec_1_dr P t (xcp, h, frs) (xcp', h', frs') = 
  τtrsys.silent_moves (mexecd P t) (τMOVE2 P) ((xcp, frs), h) ((xcp', frs'), h')"
by(blast intro: τExec_1_dr_rtranclpD rtranclp_τExec_1_dr)

lemma τExec_1_dt_conv_tranclp:
  "τExec_1_dt P t (xcp, h, frs) (xcp', h', frs') = 
  τtrsys.silent_movet (mexecd P t) (τMOVE2 P) ((xcp, frs), h) ((xcp', frs'), h')"
by(blast intro: τExec_1_dt_tranclpD tranclp_τExec_1_dt)

end

context J1_JVM_conf_read begin

lemma Red1_execd_weak_bisim:
  assumes wf: "wf_J1_prog P"
  shows "delay_bisimulation_measure (mred1 P t) (mexecd (compP2 P) t) (wbisim1 t) (ta_bisim wbisim1) (τMOVE1 P) (τMOVE2 (compP2 P)) (λ(((e, xs), exs), h) (((e', xs'), exs'), h'). sim12_size e < sim12_size e') (λ(xcpfrs, h) (xcpfrs', h). sim21_size (compP2 P) xcpfrs xcpfrs')"
proof
  fix s1 s2 s1'
  assume "wbisim1 t s1 s2" and "τtrsys.silent_move (mred1 P t) (τMOVE1 P) s1 s1'" 
  moreover obtain e xs exs h where s1: "s1 = (((e, xs), exs), h)" by(cases s1) auto
  moreover obtain e' xs' exs' h1' where s1': "s1' = (((e', xs'), exs'), h1')" by(cases s1') auto
  moreover obtain xcp frs h2 where s2: "s2 = ((xcp, frs), h2)" by(cases s2) auto
  ultimately have [simp]: "h2 = h" and red: "True,P,t ⊢1 (e, xs)/exs,h -ε (e', xs')/exs',h1'"
    and τ: "τMove1 P h ((e, xs), exs)" and bisim: "bisim1_list1 t h (e, xs) exs xcp frs" by(auto)
  from red τ bisim have h1' [simp]: "h1' = h" by(auto dest: τmove1_heap_unchanged elim!: Red1.cases bisim1_list1.cases)
  from exec_1_simulates_Red1_τ[OF wf red[unfolded h1'] bisim τ] obtain xcp' frs'
    where exec: "(if sim12_size e' < sim12_size e then τExec_1_dr else τExec_1_dt) (compP2 P) t (xcp, h, frs) (xcp', h, frs')"
    and bisim': "bisim1_list1 t h (e', xs') exs' xcp' frs'" by blast
  from exec have "(if (λ(((e, xs), exs), h) (((e', xs'), exs'), h'). sim12_size e < sim12_size e') (((e', xs'), exs'), h) (((e, xs), exs), h) then τtrsys.silent_moves (mexecd (compP2 P) t) (τMOVE2 (compP2 P)) else τtrsys.silent_movet (mexecd (compP2 P) t) (τMOVE2 (compP2 P))) ((xcp, frs), h) ((xcp', frs'), h)"
    by(auto simp add: τExec_1_dr_conv_rtranclp τExec_1_dt_conv_tranclp)
  thus "wbisim1 t s1' s2  (λ(((e, xs), exs), h) (((e', xs'), exs'), h'). sim12_size e < sim12_size e')++ s1' s1 
       (s2'. (τtrsys.silent_movet (mexecd (compP2 P) t) (τMOVE2 (compP2 P))) s2 s2'  wbisim1 t s1' s2')"
    using bisim' s1 s1' s2
    by -(rule delay_bisimulation_base.simulation_silent1I', auto split del: if_split)
next
  fix s1 s2 s2'
  assume "wbisim1 t s1 s2" and "τtrsys.silent_move (mexecd (compP2 P) t) (τMOVE2 (compP2 P)) s2 s2'"
  moreover obtain e xs exs h1 where s1: "s1 = (((e, xs), exs), h1)" by(cases s1) auto
  moreover obtain xcp frs h where s2: "s2 = ((xcp, frs), h)" by(cases s2) auto
  moreover obtain xcp' frs' h2' where s2': "s2' = ((xcp', frs'), h2')" by(cases s2') auto
  ultimately have [simp]: "h1 = h" and exec: "exec_1_d (compP2 P) t (Normal (xcp, h, frs)) ε (Normal (xcp', h2', frs'))"
    and τ: "τMove2 (compP2 P) (xcp, h, frs)" and bisim: "bisim1_list1 t h (e, xs) exs xcp frs" by(auto)
  from τRed1_simulates_exec_1_τ[OF wf exec bisim τ]
  obtain e' xs' exs' where [simp]: "h2' = h"
    and red: "(if sim21_size (compP2 P) (xcp', frs') (xcp, frs) then τRed1r else τRed1t) P t h ((e, xs), exs) ((e', xs'), exs')"
    and bisim': "bisim1_list1 t h (e', xs') exs' xcp' frs'" by blast
  from red have "(if ((λ(xcpfrs, h) (xcpfrs', h). sim21_size (compP2 P) xcpfrs xcpfrs') ((xcp', frs'), h2') ((xcp, frs), h)) then τtrsys.silent_moves (mred1 P t) (τMOVE1 P) else τtrsys.silent_movet (mred1 P t) (τMOVE1 P)) (((e, xs), exs), h) (((e', xs'), exs'), h)"
    by(auto dest: τRed1r_rtranclpD τRed1t_tranclpD)
  thus "wbisim1 t s1 s2'  (λ(xcpfrs, h) (xcpfrs', h). sim21_size (compP2 P) xcpfrs xcpfrs')++ s2' s2 
       (s1'. τtrsys.silent_movet (mred1 P t) (τMOVE1 P) s1 s1'  wbisim1 t s1' s2')"
    using bisim' s1 s2 s2'
    by -(rule delay_bisimulation_base.simulation_silent2I', auto split del: if_split)
next
  fix s1 s2 tl1 s1'
  assume "wbisim1 t s1 s2" and "mred1 P t s1 tl1 s1'" and "¬ τMOVE1 P s1 tl1 s1'"
  moreover obtain e xs exs h where s1: "s1 = (((e, xs), exs), h)" by(cases s1) auto
  moreover obtain e' xs' exs' h1' where s1': "s1' = (((e', xs'), exs'), h1')" by(cases s1') auto
  moreover obtain xcp frs h2 where s2: "s2 = ((xcp, frs), h2)" by(cases s2) auto
  ultimately have [simp]: "h2 = h"  and red: "True,P,t ⊢1 (e, xs)/exs,h -tl1 (e', xs')/exs',h1'"
    and τ: "¬ τMove1 P h ((e, xs), exs)" and bisim: "bisim1_list1 t h (e, xs) exs xcp frs"
    by(fastforce elim!: Red1.cases dest: red1_τ_taD)+
  from exec_1_simulates_Red1_not_τ[OF wf red bisim τ] obtain ta' xcp' frs' xcp'' frs''
    where exec1: "τExec_1_dr (compP2 P) t (xcp, h, frs) (xcp', h, frs')"
    and exec2: "exec_1_d (compP2 P) t (Normal (xcp', h, frs')) ta' (Normal (xcp'', h1', frs''))"
    and τ': "¬ τMove2 (compP2 P) (xcp', h, frs')"
    and bisim': "bisim1_list1 t h1' (e', xs') exs' xcp'' frs''"
    and ta': "ta_bisim wbisim1 tl1 ta'" by blast
  from exec1 have "τtrsys.silent_moves (mexecd (compP2 P) t) (τMOVE2 (compP2 P)) ((xcp, frs), h) ((xcp', frs'), h)"
    by(rule τExec_1_dr_rtranclpD)
  thus "s2' s2'' tl2. τtrsys.silent_moves (mexecd (compP2 P) t) (τMOVE2 (compP2 P)) s2 s2'  
                       mexecd (compP2 P) t s2' tl2 s2''  ¬ τMOVE2 (compP2 P) s2' tl2 s2'' 
                       wbisim1 t s1' s2''  ta_bisim wbisim1 tl1 tl2"
    using bisim' exec2 τ' s1 s1' s2 ta' unfolding h2 = h
    apply(subst (1 2) split_paired_Ex)
    apply(subst (1 2) split_paired_Ex)
    by clarify ((rule exI conjI|assumption)+, auto)
next
  fix s1 s2 tl2 s2'
  assume "wbisim1 t s1 s2" and "mexecd (compP2 P) t s2 tl2 s2'" and "¬ τMOVE2 (compP2 P) s2 tl2 s2'"
  moreover obtain e xs exs h1 where s1: "s1 = (((e, xs), exs), h1)" by(cases s1) auto
  moreover obtain xcp frs h where s2: "s2 = ((xcp, frs), h)" by(cases s2) auto
  moreover obtain xcp' frs' h2' where s2': "s2' = ((xcp', frs'), h2')" by(cases s2') auto
  ultimately have [simp]: "h1 = h"  and exec: "exec_1_d (compP2 P) t (Normal (xcp, h, frs)) tl2 (Normal (xcp', h2', frs'))"
    and τ: "¬ τMove2 (compP2 P) (xcp, h, frs)" and bisim: "bisim1_list1 t h (e, xs) exs xcp frs"
    apply auto
    apply(erule jvmd_NormalE)
    apply(cases xcp)
    apply auto
    apply(rename_tac stk loc C M pc frs)
    apply(case_tac "instrs_of (compP2 P) C M ! pc")
    apply(simp_all split: if_split_asm)
    apply(auto dest!: τexternal_red_external_aggr_TA_empty simp add: check_def has_method_def τexternal_def τexternal'_def)
    done
  from τRed1_simulates_exec_1_not_τ[OF wf exec bisim τ] obtain e' xs' exs' ta' e'' xs'' exs''
    where red1: "τRed1r P t h ((e, xs), exs) ((e', xs'), exs')"
    and red2: "True,P,t ⊢1 (e', xs')/exs',h -ta' (e'', xs'')/exs'',h2'"
    and τ': "¬ τMove1 P h ((e', xs'), exs')" and ta': "ta_bisim wbisim1 ta' tl2"
    and bisim': "bisim1_list1 t h2' (e'', xs'') exs'' xcp' frs'" by blast
  from red1 have "τtrsys.silent_moves (mred1 P t) (τMOVE1 P) (((e, xs), exs), h) (((e', xs'), exs'), h)"
    by(rule τRed1r_rtranclpD)
  thus "s1' s1'' tl1. τtrsys.silent_moves (mred1 P t) (τMOVE1 P) s1 s1'  mred1 P t s1' tl1 s1'' 
                      ¬ τMOVE1 P s1' tl1 s1''  wbisim1 t s1'' s2'  ta_bisim wbisim1 tl1 tl2"
    using bisim' red2 τ' s1 s2 s2' h1 = h ta'
    apply -
    apply(rule exI[where x="(((e', xs'), exs'), h)"])
    apply(rule exI[where x="(((e'', xs''), exs''), h2')"])
    apply(rule exI[where x="ta'"])
    apply auto
    done
next
  have "wf (inv_image {(x, y). x < y} (λ(((e, xs), exs), h). sim12_size e))"
    by(rule wf_inv_image)(rule wf_less)
  also have "inv_image {(x, y). x < y} (λ(((e, xs), exs), h). sim12_size e) =
    {(x, y). (λ(((e, xs), exs), h) (((e', xs'), exs'), h'). sim12_size e < sim12_size e') x y}" by auto
  finally show "wfP (λ(((e, xs), exs), h) (((e', xs'), exs'), h'). sim12_size e < sim12_size e')"
    unfolding wfP_def .
next
  from wfP_sim21_size
  have "wf {(xcpfrs, xcpfrs'). sim21_size (compP2 P) xcpfrs xcpfrs'}" by(unfold wfP_def)
  hence "wf (inv_image {(xcpfrs, xcpfrs'). sim21_size (compP2 P) xcpfrs xcpfrs'} fst)" by(rule wf_inv_image)
  also have "inv_image {(xcpfrs, xcpfrs'). sim21_size (compP2 P) xcpfrs xcpfrs'} fst =
    {((xcpfrs, h), (xcpfrs', h)). sim21_size (compP2 P) xcpfrs xcpfrs'}" by auto
  also have " = {(x, y). (λ(xcpfrs, h) (xcpfrs', h). sim21_size (compP2 P) xcpfrs xcpfrs') x y}" by(auto)
  finally show "wfP (λ(xcpfrs, h) (xcpfrs', h). sim21_size (compP2 P) xcpfrs xcpfrs')"
    unfolding wfP_def .
qed

lemma Red1_execd_delay_bisim:
  assumes wf: "wf_J1_prog P"
  shows "delay_bisimulation_diverge (mred1 P t) (mexecd (compP2 P) t) (wbisim1 t) (ta_bisim wbisim1) (τMOVE1 P) (τMOVE2 (compP2 P))"
proof -
  interpret delay_bisimulation_measure
    "mred1 P t" "mexecd (compP2 P) t" "wbisim1 t" "ta_bisim wbisim1" "τMOVE1 P" "τMOVE2 (compP2 P)"
    "λ(((e, xs), exs), h) (((e', xs'), exs'), h'). sim12_size e < sim12_size e'"
    "λ(xcpfrs, h) (xcpfrs', h). sim21_size (compP2 P) xcpfrs xcpfrs'"
    using wf by(rule Red1_execd_weak_bisim)
  show ?thesis by(unfold_locales)
qed

end

definition bisim_wait1JVM :: 
  "'addr jvm_prog  ('addr expr1 × 'addr locals1) × ('addr expr1 × 'addr locals1) list  'addr jvm_thread_state  bool"
where
  "bisim_wait1JVM P  
  λ((e1, xs1), exs1) (xcp, frs). call1 e1  None  
     (case frs of Nil  False | (stk, loc, C, M, pc) # frs'  M' n. instrs_of P C M ! pc = Invoke M' n)"

sublocale J1_JVM_heap_conf_base < Red1_execd:
  FWbisimulation_base 
    final_expr1
    "mred1 P"
    JVM_final
    "mexecd (compP2 P)"
    convert_RA
    wbisim1
    "bisim_wait1JVM (compP2 P)" 
.

sublocale JVM_heap_base < execd_mthr:
  τmultithreaded
    JVM_final
    "mexecd P"
    convert_RA
    "τMOVE2 P"
  for P
by(unfold_locales)

sublocale J1_JVM_heap_conf_base < Red1_execd:
  FWdelay_bisimulation_base 
    final_expr1
    "mred1 P"
    JVM_final
    "mexecd (compP2 P)"
    convert_RA
    "wbisim1"
    "bisim_wait1JVM (compP2 P)" 
    "τMOVE1 P"
    "τMOVE2 (compP2 P)"
by(unfold_locales)

context J1_JVM_conf_read begin

theorem Red1_exec1_FWwbisim:
  assumes wf: "wf_J1_prog P"
  shows "FWdelay_bisimulation_diverge final_expr1 (mred1 P) JVM_final (mexecd (compP2 P)) wbisim1 (bisim_wait1JVM (compP2 P)) (τMOVE1 P) (τMOVE2 (compP2 P))"
proof -
  let ?exec = "mexecd (compP2 P)"
  let ?τexec = "λt. τtrsys.silent_moves (mexecd (compP2 P) t) (τMOVE2 (compP2 P))"
  let ?τred = "λt. τtrsys.silent_moves (mred1 P t) (τMOVE1 P)"
  interpret delay_bisimulation_diverge 
    "mred1 P t" "?exec t" "wbisim1 t" "ta_bisim wbisim1" "τMOVE1 P" "τMOVE2 (compP2 P)"
    for t
    using wf by(rule Red1_execd_delay_bisim)
  show ?thesis
  proof
    fix t s1 s2
    assume "wbisim1 t s1 s2" "(λ(x1, m). final_expr1 x1) s1"
    moreover obtain e xs exs m1 where [simp]: "s1 = (((e, xs), exs), m1)" by(cases s1) auto
    moreover obtain xcp frs m2 where [simp]: "s2 = ((xcp, frs), m2)" by(cases s2) auto
    ultimately have [simp]: "m2 = m1" "exs = []"
      and "bisim1_list1 t m1 (e, xs) [] xcp frs" 
      and "final e" by auto
    from ‹bisim1_list1 t m1 (e, xs) [] xcp frs ‹final e
    show "s2'. ?τexec t s2 s2'  wbisim1 t s1 s2'  (λ(x2, m). JVM_final x2) s2'"
    proof cases
      case (bl1_Normal stk loc C M pc frs' Ts T body D)
      hence [simp]: "frs = [(stk, loc, C, M, pc)]"
        and conf: "compTP P  t:(xcp, m1, frs) "
        and sees: "P  C sees M: TsT = body in D"
        and bisim: "P,blocks1 0 (Class D # Ts) body,m1  (e, xs)  (stk, loc, pc, xcp)"
        and var: "max_vars e  length xs" by auto
      from ‹final e show ?thesis
      proof cases
        fix v
        assume [simp]: "e = Val v"
        with bisim have [simp]: "xcp = None" "xs = loc"
          and exec: "τExec_mover_a P t (blocks1 0 (Class D # Ts) body) m1 (stk, loc, pc, xcp) ([v], loc, length (compE2 body), None)"
          by(auto dest!: bisim1Val2D1)
        from exec have "τExec_mover_a P t body m1 (stk, loc, pc, xcp) ([v], loc, length (compE2 body), None)"
          unfolding  τExec_mover_blocks1 .
        with sees have "τExec_1r (compP2 P) t (xcp, m1, frs) (None, m1, [([v], loc, C, M, length (compE2 body))])"
          by(auto intro: τExec_mover_τExec_1r)
        with wt_compTP_compP2[OF wf]
        have execd: "τExec_1_dr (compP2 P) t (xcp, m1, frs) (None, m1, [([v], loc, C, M, length (compE2 body))])"
          using conf by(rule τExec_1r_τExec_1_dr)
        also from sees_method_compP[OF sees, of "λC M Ts T. compMb2"] sees max_stack1[of body]
        have "τexec_1_d (compP2 P) t (None, m1, [([v], loc, C, M, length (compE2 body))]) (None, m1, [])"
          by(auto simp add: τexec_1_d_def compP2_def compMb2_def check_def has_methodI intro: exec_1I)
        finally have "?τexec t s2 ((None, []), m1)"
          unfolding τExec_1_dr_conv_rtranclp by simp
        moreover have "JVM_final (None, [])" by simp
        moreover from conf have "hconf m1" "preallocated m1" unfolding correct_state_def by(simp_all)
        hence "wbisim1 t s1 ((None, []), m1)" by(auto intro: bisim1_list1.intros)
        ultimately show ?thesis by blast
      next
        fix a
        assume [simp]: "e = throw (addr a)"
        hence "stk' loc' pc'. τExec_mover_a P t body m1 (stk, loc, pc, xcp) (stk', loc', pc', a)  P,blocks1 0 (Class D # Ts) body,m1  (Throw a, xs)  (stk', loc', pc', a)"
        proof(cases xcp)
          case None
          with bisim show ?thesis
            by(fastforce dest!: bisim1_Throw_τExec_movet simp del: blocks1.simps intro: tranclp_into_rtranclp)
        next
          case (Some a')
          with bisim have "a = a'" by(auto dest: bisim1_ThrowD)
          with Some bisim show ?thesis by(auto)
        qed
        then obtain stk' loc' pc'
          where exec: "τExec_mover_a P t body m1 (stk, loc, pc, xcp) (stk', loc', pc', a)" 
          and bisim': "P,blocks1 0 (Class D # Ts) body,m1  (throw (addr a), xs)  (stk', loc', pc', a)" by blast
        with sees have "τExec_1r (compP2 P) t (xcp, m1, frs) (a, m1, [(stk', loc', C, M, pc')])"
          by(auto intro: τExec_mover_τExec_1r)
        with wt_compTP_compP2[OF wf]
        have execd: "τExec_1_dr (compP2 P) t (xcp, m1, frs) (a, m1, [(stk', loc', C, M, pc')])"
          using conf by(rule τExec_1r_τExec_1_dr)
        also {
          from bisim1_xcp_Some_not_caught[OF bisim', of "λC M Ts T. compMb2" 0 0]
          have "match_ex_table (compP2 P) (cname_of m1 a) pc' (compxE2 body 0 0) = None" by(simp add: compP2_def)
          moreover from bisim' have "pc' < length (compE2 body)" by(auto dest: bisim1_ThrowD)
          ultimately have "τexec_1 (compP2 P) t (a, m1, [(stk', loc', C, M, pc')]) (a, m1, [])"
            using sees_method_compP[OF sees, of "λC M Ts T. compMb2"] sees
            by(auto simp add: τexec_1_def compP2_def compMb2_def has_methodI intro: exec_1I)
          moreover from wt_compTP_compP2[OF wf] execd conf
          have "compTP P  t:(a, m1, [(stk', loc', C, M, pc')]) " by(rule τExec_1_dr_preserves_correct_state)
          ultimately have "τexec_1_d (compP2 P) t (a, m1, [(stk', loc', C, M, pc')]) (a, m1, [])"
            using wt_compTP_compP2[OF wf]
            by(auto simp add: τexec_1_def τexec_1_d_def welltyped_commute[symmetric] elim: jvmd_NormalE) }
        finally have "?τexec t s2 ((a, []), m1)"
          unfolding τExec_1_dr_conv_rtranclp by simp
        moreover have "JVM_final (a, [])" by simp
        moreover from conf have "hconf m1" "preallocated m1" by(simp_all add: correct_state_def)
        hence "wbisim1 t s1 ((a, []), m1)" by(auto intro: bisim1_list1.intros)
        ultimately show ?thesis by blast
      qed
    qed(auto intro!: exI bisim1_list1.intros)
  next
    fix t s1 s2
    assume "wbisim1 t s1 s2" "(λ(x2, m). JVM_final x2) s2"
    moreover obtain e xs exs m1 where [simp]: "s1 = (((e, xs), exs), m1)" by(cases s1) auto
    moreover obtain xcp frs m2 where [simp]: "s2 = ((xcp, frs), m2)" by(cases s2) auto
    ultimately have [simp]: "m2 = m1" "exs = []" "frs = []"
      and bisim: "bisim1_list1 t m1 (e, xs) [] xcp []" by(auto elim: bisim1_list1.cases)
    hence "final e" by(auto elim: bisim1_list1.cases)
    thus "s1'. ?τred t s1 s1'  wbisim1 t s1' s2  (λ(x1, m). final_expr1 x1) s1'" using bisim by auto
  next
    fix t' x m1 xx m2 t x1 x2 x1' ta1 x1'' m1' x2' ta2 x2'' m2'
    assume b: "wbisim1 t' (x, m1) (xx, m2)" and b': "wbisim1 t (x1, m1) (x2, m2)"
      and τred: "?τred t (x1, m1) (x1', m1)"
      and red: "mred1 P t (x1', m1) ta1 (x1'', m1')"
      and "¬ τMOVE1 P (x1', m1) ta1 (x1'', m1')"
      and τexec: "?τexec t (x2, m2) (x2', m2)"
      and exec: "?exec t (x2', m2) ta2 (x2'', m2')"
      and "¬ τMOVE2 (compP2 P) (x2', m2) ta2 (x2'', m2')"
      and b2: "wbisim1 t (x1'', m1') (x2'', m2')"
    from red have "hext m1 m1'" by(auto simp add: split_beta intro: Red1_hext_incr)
    moreover from b2 have "m1' = m2'" by(cases x1'', cases x2'') simp
    moreover from b2 have "hconf m2'"
      by(cases x1'', cases x2'')(auto elim!: bisim1_list1.cases simp add: correct_state_def)
    moreover from b' exec have "preallocated m2"
      by(cases x1, cases x2)(auto elim!: bisim1_list1.cases simp add: correct_state_def)
    moreover from b' τred red have tconf: "compP2 P,m2  t √t"
      by(cases x1, cases x2)(auto elim!: bisim1_list1.cases Red1.cases simp add: correct_state_def τmreds1_Val_Nil τmreds1_Throw_Nil)
    from τexec have τexec': "τExec_1_dr (compP2 P) t (fst x2, m2, snd x2) (fst x2', m2, snd x2')"
      unfolding τExec_1_dr_conv_rtranclp by simp
    with b' tconf have "compTP P  t: (fst x2', m2, snd x2') "
      using ‹preallocated m2
      apply(cases x1, cases x2)
      apply(erule τExec_1_dr_preserves_correct_state[OF wt_compTP_compP2[OF wf]])
      apply(auto elim!: bisim1_list1.cases simp add: correct_state_def)
      done
    ultimately show "wbisim1 t' (x, m1') (xx, m2')" using b exec
      apply(cases x, cases xx)
      apply(auto elim!: bisim1_list1.cases intro!: bisim1_list1.intros simp add: split_beta intro: preallocated_hext)
        apply(erule (2) correct_state_heap_change[OF wt_compTP_compP2[OF wf]])
       apply(erule (1) bisim1_hext_mono)
      apply(erule List.list_all2_mono)
      apply(erule (1) bisim1_fr_hext_mono)
      done
  next
    fix t x1 m1 x2 m2 x1' ta1 x1'' m1' x2' ta2 x2'' m2' w
    assume b: "wbisim1 t (x1, m1) (x2, m2)"
      and τred: "?τred t (x1, m1) (x1', m1)"
      and red: "mred1 P t (x1', m1) ta1 (x1'', m1')"
      and "¬ τMOVE1 P (x1', m1) ta1 (x1'', m1')"
      and τexec: "?τexec t (x2, m2) (x2', m2)"
      and exec: "?exec t (x2', m2) ta2 (x2'', m2')"
      and "¬ τMOVE2 (compP2 P) (x2', m2) ta2 (x2'', m2')"
      and b': "wbisim1 t (x1'', m1') (x2'', m2')"
      and "ta_bisim wbisim1 ta1 ta2"
      and Suspend: "Suspend w  set ta1w" "Suspend w  set ta2w"
    from red Suspend 
    have "call1 (fst (fst x1''))  None"
      by(cases x1')(cases x1'', auto dest: Red1_Suspend_is_call)
    moreover from mexecd_Suspend_Invoke[OF exec Suspend(2)]
    obtain xcp stk loc C M pc frs' M' n where "x2'' = (xcp, (stk, loc, C, M, pc) # frs')"
      "instrs_of (compP2 P) C M ! pc = Invoke M' n" by blast
    ultimately show "bisim_wait1JVM (compP2 P) x1'' x2''"
      by(simp add: bisim_wait1JVM_def split_beta)
  next
    fix t x1 m1 x2 m2 ta1 x1' m1'
    assume "wbisim1 t (x1, m1) (x2, m2)"
      and "bisim_wait1JVM (compP2 P) x1 x2"
      and "mred1 P t (x1, m1) ta1 (x1', m1')"
      and wakeup: "Notified  set ta1w  WokenUp  set ta1w"
    moreover obtain e1 xs1 exs1 where [simp]: "x1 = ((e1, xs1), exs1)" by(cases x1) auto
    moreover obtain xcp frs where [simp]: "x2 = (xcp, frs)" by(cases x2)
    moreover obtain e1' xs1' exs1' where [simp]: "x1' = ((e1', xs1'), exs1')" by(cases x1') auto
    ultimately have [simp]: "m1 = m2" 
      and bisim: "bisim1_list1 t m2 (e1, xs1) exs1 xcp frs"
      and red: "True,P,t ⊢1 (e1, xs1)/exs1, m2 -ta1 (e1', xs1')/exs1', m1'"
      and call: "call1 e1  None" 
                "case frs of []  False | (stk, loc, C, M, pc) # frs'  M' n. instrs_of (compP2 P) C M ! pc = Invoke M' n"
      by(auto simp add: bisim_wait1JVM_def split_def)
    from red wakeup have "¬ τMove1 P m2 ((e1, xs1), exs1)"
      by(auto elim!: Red1.cases dest: red1_τ_taD simp add: split_beta ta_upd_simps)
    from exec_1_simulates_Red1_not_τ[OF wf red bisim this] call
    show "ta2 x2' m2'. mexecd (compP2 P) t (x2, m2) ta2 (x2', m2')  wbisim1 t (x1', m1') (x2', m2')  ta_bisim wbisim1 ta1 ta2"
      by(auto simp del: not_None_eq simp add: split_paired_Ex ta_bisim_def ta_upd_simps split: list.split_asm)
  next
    fix t x1 m1 x2 m2 ta2 x2' m2'
    assume "wbisim1 t (x1, m1) (x2, m2)"
      and "bisim_wait1JVM (compP2 P) x1 x2"
      and "mexecd (compP2 P) t (x2, m2) ta2 (x2', m2')"
      and wakeup: "Notified  set ta2w  WokenUp  set ta2w"
    moreover obtain e1 xs1 exs1 where [simp]: "x1 = ((e1, xs1), exs1)" by(cases x1) auto
    moreover obtain xcp frs where [simp]: "x2 = (xcp, frs)" by(cases x2)
    moreover obtain xcp' frs' where [simp]: "x2' = (xcp', frs')" by(cases x2')
    ultimately have [simp]: "m1 = m2" 
      and bisim: "bisim1_list1 t m2 (e1, xs1) exs1 xcp frs"
      and exec: "compP2 P,t  Normal (xcp, m2, frs) -ta2-jvmd→ Normal (xcp', m2', frs')"
      and call: "call1 e1  None" 
                "case frs of []  False | (stk, loc, C, M, pc) # frs'  M' n. instrs_of (compP2 P) C M ! pc = Invoke M' n"
      by(auto simp add: bisim_wait1JVM_def split_def)
    from exec wakeup have "¬ τMove2 (compP2 P) (xcp, m2, frs)"
      by(auto dest: τexec_1_taD simp add: split_beta ta_upd_simps)
    from τRed1_simulates_exec_1_not_τ[OF wf exec bisim this] call
    show "ta1 x1' m1'. mred1 P t (x1, m1) ta1 (x1', m1')  wbisim1 t (x1', m1') (x2', m2')  ta_bisim wbisim1 ta1 ta2"
      by(auto simp del: not_None_eq simp add: split_paired_Ex ta_bisim_def ta_upd_simps split: list.split_asm)
  next
    show "(x. final_expr1 x)  (x. JVM_final x)"
      by(auto simp add: split_paired_Ex final_iff)
  qed
qed

end

sublocale J1_JVM_heap_conf_base < Red1_mexecd:
  FWbisimulation_base
    final_expr1
    "mred1 P"
    JVM_final
    "mexecd (compP2 P)"
    convert_RA
    "wbisim1"
    "bisim_wait1JVM (compP2 P)"
.

context J1_JVM_heap_conf begin

lemma bisim_J1_JVM_start:
  assumes wf: "wf_J1_prog P"
  and wf_start: "wf_start_state P C M vs"
  shows "Red1_execd.mbisim (J1_start_state P C M vs) (JVM_start_state (compP2 P) C M vs)"
proof -
  from wf_start obtain Ts T body D where start: "start_heap_ok"
  and sees: "P  C sees M:TsT=body in D" and conf: "P,start_heap  vs [:≤] Ts" by cases

  let ?e = "blocks1 0 (Class D#Ts) body"
  let ?xs = "Null # vs @ replicate (max_vars body) undefined_value"

  from sees_wf_mdecl[OF wf sees] obtain T'
    where B: "ℬ body (Suc (length Ts))"
    and wt: "P,Class D # Ts ⊢1 body :: T'"
    and da: "𝒟 body {..length Ts}"
    and sv: "syncvars body"
    by(auto simp add: wf_mdecl_def)

  have "P,?e,start_heap  (?e, ?xs)  ([], ?xs, 0, None)" by(rule bisim1_refl)
  moreover
  from wf have wf': "wf_jvm_progcompTP P (compP2 P)" by(rule wt_compTP_compP2)
  from sees_method_compP[OF sees, of "λC M Ts T. compMb2"]
  have sees': "compP2 P  C sees M: TsT = compMb2 body in D" by(simp add: compP2_def)
  from conf have "compP2 P,start_heap  vs [:≤] Ts" by(simp add: compP2_def heap_base.compP_confs)
  from BV_correct_initial[OF wf' start sees' this] sees'
  have "compTP P  start_tid:(None, start_heap, [([], ?xs, D, M, 0)]) "
      by(simp add: JVM_start_state'_def compP2_def compMb2_def)
  hence "bisim1_list1 start_tid start_heap (?e, ?xs) [] None [([], ?xs, D, M, 0)]"
    using sees_method_idemp[OF sees]
  proof
    show "P,?e,start_heap  (?e, ?xs)  ([], ?xs, 0, None)"
      by(rule bisim1_refl)
    show "max_vars ?e  length ?xs" using conf
      by(auto simp add: blocks1_max_vars dest: list_all2_lengthD)
  qed simp
  thus ?thesis
    using sees sees' unfolding start_state_def
    by -(rule Red1_execd.mbisimI, auto split: if_split_asm intro: wset_thread_okI simp add: compP2_def compMb2_def)
qed

lemmas τred1_Val_simps = τred1r_Val τred1t_Val τreds1r_map_Val τreds1t_map_Val

end

end

Theory ListIndex

(*  Title:      JinjaThreads/Compiler/ListIndex.thy
    Author:     Tobias Nipkow, Andreas Lochbihler
*)

section ‹Indexing variables in variable lists›

theory ListIndex imports Main begin

text‹In order to support local variables and arbitrarily nested
blocks, the local variables are arranged as an indexed list. The
outermost local variable (``this'') is the first element in the list,
the most recently created local variable the last element. When
descending into a block structure, a corresponding list @{term Vs} of
variable names is maintained. To find the index of some variable
@{term V}, we have to find the index of the \emph{last} occurrence of
@{term V} in @{term Vs}. This is what @{term index} does:›

primrec index :: "'a list  'a  nat"
where
  "index [] y = 0"
| "index (x#xs) y =
  (if x=y then if x  set xs then index xs y + 1 else 0 else index xs y + 1)"

definition hidden :: "'a list  nat  bool"
where "hidden xs i    i < size xs  xs!i  set(drop (i+1) xs)"

subsection @{term index}

lemma [simp]: "index (xs @ [x]) x = size xs"
(*<*)by(induct xs) simp_all(*>*)


lemma [simp]: "(index (xs @ [x]) y = size xs) = (x = y)"
(*<*)by(induct xs) auto(*>*)


lemma [simp]: "x  set xs  xs ! index xs x = x"
(*<*)by(induct xs) auto(*>*)


lemma [simp]: "x  set xs  index xs x = size xs"
(*<*)by(induct xs) auto(*>*)


lemma index_size_conv[simp]: "(index xs x = size xs) = (x  set xs)"
(*<*)by(induct xs) auto(*>*)


lemma size_index_conv[simp]: "(size xs = index xs x) = (x  set xs)"
(*<*)by(induct xs) auto(*>*)


lemma "(index xs x < size xs) = (x  set xs)"
(*<*)by(induct xs) auto(*>*)


lemma [simp]: " y  set xs; x  y   index (xs @ [x]) y = index xs y"
(*<*)by(induct xs) auto(*>*)


lemma index_less_size[simp]: "x  set xs  index xs x < size xs"
(*<*)
apply(induct xs)
 apply simp
apply(fastforce)
done
(*>*)

lemma index_less_aux: "x  set xs; size xs  n  index xs x < n"
(*<*)
apply(subgoal_tac "index xs x < size xs")
apply(simp (no_asm_simp))
apply simp
done
(*>*)


lemma [simp]: "x  set xs  y  set xs  (index xs x = index xs y) = (x = y)"
(*<*)by (induct xs) auto(*>*)


lemma inj_on_index: "inj_on (index xs) (set xs)"
(*<*)by(simp add:inj_on_def)(*>*)


lemma index_drop: "x i.  x  set xs; index xs x < i   x  set(drop i xs)"
(*<*)
apply(induct xs)
apply (auto simp:drop_Cons split:if_split_asm nat.splits dest:in_set_dropD)
done
(*>*)


subsection @{term hidden}

lemma hidden_index: "x  set xs  hidden (xs @ [x]) (index xs x)"
(*<*)
apply(auto simp add:hidden_def index_less_aux nth_append)
 apply(drule index_less_size)
 apply(simp del:index_less_size)
done
(*>*)


lemma hidden_inacc: "hidden xs i  index xs x  i"
(*<*)
apply(case_tac "x  set xs")
apply(auto simp add:hidden_def index_less_aux nth_append index_drop)
done
(*>*)


lemma [simp]: "hidden xs i  hidden (xs@[x]) i"
(*<*)by(auto simp add:hidden_def nth_append)(*>*)


lemma fun_upds_apply: "m ys.
  (m(xs[↦]ys)) x =
  (let xs' = take (size ys) xs
   in if x  set xs' then Some(ys ! index xs' x) else m x)"
(*<*)
apply(induct xs)
 apply (simp add:Let_def)
apply(case_tac ys)
 apply (simp add:Let_def)
apply (simp add:Let_def)
done
(*>*)


lemma map_upds_apply_eq_Some:
  "((m(xs[↦]ys)) x = Some y) =
  (let xs' = take (size ys) xs
   in if x  set xs' then ys ! index xs' x = y else m x = Some y)"
(*<*)by(simp add:fun_upds_apply Let_def)(*>*)


lemma map_upds_upd_conv_index:
  "x  set xs; size xs  size ys 
   m(xs[↦]ys)(xy) = m(xs[↦]ys[index xs x := y])"
(*<*)
apply(rule ext)
apply(simp add:fun_upds_apply index_less_aux eq_sym_conv Let_def)
done
(*>*)

lemma image_index:
  "A  set(xs@[x])  index (xs @ [x]) ` A =
  (if x  A then insert (size xs) (index xs ` (A-{x})) else index xs ` A)"
(*<*)
apply(auto simp:image_def)
   apply(rule bexI)
    prefer 2 apply blast
   apply simp
  apply(rule ccontr)
  apply(erule_tac x=xa in ballE)
   prefer 2 apply blast
  apply(fastforce simp add:neq_commute)
 apply(subgoal_tac "x  xa")
  prefer 2 apply blast
 apply(fastforce simp add:neq_commute)
apply(subgoal_tac "x  xa")
 prefer 2 apply blast
apply(force)
done
(*>*)

lemma index_le_lengthD: "index xs x < length xs  x  set xs"
by(erule contrapos_pp)(simp)

lemma not_hidden_index_nth: " i < length Vs; ¬ hidden Vs i   index Vs (Vs ! i) = i"
by(induct Vs arbitrary: i)(auto split: if_split_asm nat.split_asm simp add: nth_Cons hidden_def)

lemma hidden_snoc_nth:
  assumes len: "i < length Vs"
  shows "hidden (Vs @ [Vs ! i]) i"
proof(cases "hidden Vs i")
  case True thus ?thesis by simp
next
  case False
  with len have "index Vs (Vs ! i) = i" by(rule not_hidden_index_nth)
  moreover from len have "hidden (Vs @ [Vs ! i]) (index Vs (Vs ! i))"
    by(auto intro: hidden_index)
  ultimately show ?thesis by simp
qed

lemma map_upds_Some_eq_nth_index:
  assumes "[Vs [↦] vs] V = Some v" "length Vs  length vs"
  shows "vs ! index Vs V = v"
proof -
  from [Vs [↦] vs] V = Some v have "V  set Vs"
    by -(rule classical, auto)
  with [Vs [↦] vs] V = Some v ‹length Vs  length vs show ?thesis
  proof(induct Vs arbitrary: vs)
    case Nil thus ?case by simp
  next
    case (Cons x xs ys)
    note IH = vs.  [xs [↦] vs] V = Some v; length xs  length vs; V  set xs   vs ! index xs V = v
    from [x # xs [↦] ys] V = Some v obtain y Ys where "ys = y # Ys" by(cases ys, auto)
    with ‹length (x # xs)  length ys have "length xs  length Ys" by simp
    show ?case
    proof(cases "V  set xs")
      case True
      with [x # xs [↦] ys] V = Some v ‹length xs  length Ys ys = y # Ys
      have "[xs [↦] Ys] V = Some v"
        apply(auto simp add: map_upds_def map_of_eq_None_iff set_zip image_Collect split: if_split_asm)
        apply(clarsimp simp add: in_set_conv_decomp)
        apply(hypsubst_thin)
        apply(erule_tac x="length ys" in allE)
        by(simp)
      with IH[OF this ‹length xs  length Ys True] ys = y # Ys True
      show ?thesis by(simp)
    next
      case False with V  set (x # xs) have "x = V" by auto
      with False [x # xs [↦] ys] V = Some v ys = y # Ys have "y = v"
        by(auto)
      with False x = V ys = y # Ys 
      show ?thesis by(simp)
    qed
  qed
qed

end

Theory Compiler1

(*  Title:      JinjaThreads/Compiler/Compiler1.thy
    Author:     Andreas Lochbihler, Tobias Nipkow

    Based on Jinja/Compiler/Compiler1
*)

section ‹Compilation Stage 1›

theory Compiler1 imports
  PCompiler
  J1State
  ListIndex 
begin

definition fresh_var :: "vname list  vname"
  where "fresh_var Vs = sum_list (STR ''V'' # Vs)"

lemma fresh_var_fresh: "fresh_var Vs  set Vs"
proof -
  have "V  set Vs  length (String.explode V) < length (String.explode (fresh_var Vs))" for V
    by (induction Vs) (auto simp add: fresh_var_def Literal.rep_eq)
  then show ?thesis
    by auto
qed

text‹Replacing variable names by indices.›

function compE1  :: "vname list  'addr expr       'addr expr1"
  and compEs1 :: "vname list  'addr expr list  'addr expr1 list"
where
  "compE1 Vs (new C) = new C"
| "compE1 Vs (newA Te) = newA TcompE1 Vs e"
| "compE1 Vs (Cast T e) = Cast T (compE1 Vs e)"
| "compE1 Vs (e instanceof T) = (compE1 Vs e) instanceof T"
| "compE1 Vs (Val v) = Val v"
| "compE1 Vs (Var V) = Var(index Vs V)"
| "compE1 Vs (e«bop»e') = (compE1 Vs e)«bop»(compE1 Vs e')"
| "compE1 Vs (V:=e) = (index Vs V):= (compE1 Vs e)"
| "compE1 Vs (ai) = (compE1 Vs a)compE1 Vs i"
| "compE1 Vs (ai:=e) = (compE1 Vs a)compE1 Vs i:=compE1 Vs e"
| "compE1 Vs (a∙length) = compE1 Vs a∙length"
| "compE1 Vs (eF{D}) = compE1 Vs eF{D}"
| "compE1 Vs (eF{D}:=e') = compE1 Vs eF{D}:=compE1 Vs e'"
| "compE1 Vs (e∙compareAndSwap(DF, e', e'')) = compE1 Vs e∙compareAndSwap(DF, compE1 Vs e', compE1 Vs e'')"
| "compE1 Vs (eM(es)) = (compE1 Vs e)M(compEs1 Vs es)"
| "compE1 Vs {V:T=vo; e} = {(size Vs):T=vo; compE1 (Vs@[V]) e}"
| "compE1 Vs (syncU (o') e) = synclength Vs (compE1 Vs o') (compE1 (Vs@[fresh_var Vs]) e)"
| "compE1 Vs (insyncU (a) e) = insynclength Vs (a) (compE1 (Vs@[fresh_var Vs]) e)"
| "compE1 Vs (e1;;e2) = (compE1 Vs e1);;(compE1 Vs e2)"
| "compE1 Vs (if (b) e1 else e2) = (if (compE1 Vs b) (compE1 Vs e1) else (compE1 Vs e2))"
| "compE1 Vs (while (b) e) = (while (compE1 Vs b) (compE1 Vs e))"
| "compE1 Vs (throw e) = throw (compE1 Vs e)"
| "compE1 Vs (try e1 catch(C V) e2) = try(compE1 Vs e1) catch(C (size Vs)) (compE1 (Vs@[V]) e2)"

| "compEs1 Vs []     = []"
| "compEs1 Vs (e#es) = compE1 Vs e # compEs1 Vs es"
by pat_completeness auto
termination
apply(relation "case_sum (λp. size (snd p)) (λp. size_list size (snd p)) <*mlex*> {}")
apply(rule wf_mlex[OF wf_empty])
apply(rule mlex_less, simp)+
done

lemmas compE1_compEs1_induct =
  compE1_compEs1.induct[case_names New NewArray Cast InstanceOf Val Var BinOp LAss AAcc AAss ALen FAcc FAss CAS Call Block Synchronized InSynchronized Seq Cond While throw TryCatch Nil Cons]

lemma compEs1_conv_map [simp]: "compEs1 Vs es = map (compE1 Vs) es"
by(induct es) simp_all

lemmas compEs1_map_Val = compEs1_conv_map

lemma compE1_eq_Val [simp]: "compE1 Vs e = Val v  e = Val v"
apply(cases e, auto)
done

lemma Val_eq_compE1 [simp]: "Val v = compE1 Vs e  e = Val v"
apply(cases e, auto)
done

lemma compEs1_eq_map_Val [simp]: "compEs1 Vs es = map Val vs  es = map Val vs"
apply(induct es arbitrary: vs)
apply(auto, blast)
done

lemma compE1_eq_Var [simp]: "compE1 Vs e = Var V  (V'. e = Var V'  V = index Vs V')"
by(cases e, auto)

lemma compE1_eq_Call [simp]:
  "compE1 Vs e = objM(params)  (obj' params'. e = obj'M(params')  compE1 Vs obj' = obj  compEs1 Vs params' = params)"
by(cases e, auto)

lemma length_compEs2 [simp]:
  "length (compEs1 Vs es) = length es"
by(simp add: compEs1_conv_map)

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows expr_locks_compE1 [simp]: "expr_locks (compE1 Vs e) = expr_locks e"
  and expr_lockss_compEs1 [simp]: "expr_lockss (compEs1 Vs es) = expr_lockss es"
by(induct Vs e and Vs es rule: compE1_compEs1.induct)(auto intro: ext)

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows contains_insync_compE1 [simp]: "contains_insync (compE1 Vs e) = contains_insync e"
  and contains_insyncs_compEs1 [simp]: "contains_insyncs (compEs1 Vs es) = contains_insyncs es"
by(induct Vs e and Vs es rule: compE1_compEs1.induct)simp_all

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows max_vars_compE1: "max_vars (compE1 Vs e) = max_vars e"
  and max_varss_compEs1: "max_varss (compEs1 Vs es) = max_varss es"
apply(induct Vs e and Vs es rule: compE1_compEs1.induct)
apply(auto)
done

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows: "size Vs = n (compE1 Vs e) n"
  and ℬs: "size Vs = n  ℬs (compEs1 Vs es) n"
apply(induct Vs e and Vs es arbitrary: n and n rule: compE1_compEs1.induct)
apply auto
done

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows fv_compE1: "fv e  set Vs  fv (compE1 Vs e) = (index Vs) ` (fv e)"
  and fvs_compEs1: "fvs es  set Vs  fvs (compEs1 Vs es) = (index Vs) ` (fvs es)"
proof(induct Vs e and Vs es rule: compE1_compEs1_induct)
  case (Block Vs V ty vo exp)
  have IH: "fv exp  set (Vs @ [V])  fv (compE1 (Vs @ [V]) exp) = index (Vs @ [V]) ` fv exp" by fact
  from ‹fv {V:ty=vo; exp}  set Vs have fv': "fv exp  set (Vs @ [V])" by auto
  from IH[OF this] have IH': "fv (compE1 (Vs @ [V]) exp) = index (Vs @ [V]) ` fv exp" .
  have "fv (compE1 (Vs @ [V]) exp) - {length Vs} = index Vs ` (fv exp - {V})"
  proof(rule equalityI[OF subsetI subsetI])
    fix x
    assume x: "x  fv (compE1 (Vs @ [V]) exp) - {length Vs}"
    hence "x  length Vs" by simp
    from x IH' have "x  index (Vs @ [V]) ` fv exp" by simp
    thus "x  index Vs ` (fv exp - {V})"
    proof(rule imageE)
      fix y
      assume [simp]: "x = index (Vs @ [V]) y"
        and y: "y  fv exp"
      have "y  V"
      proof
        assume [simp]: "y = V"
        hence "x = length Vs" by simp
        with x  length Vs show False by contradiction
      qed
      moreover with fv' y have "y  set Vs" by auto
      ultimately have "index (Vs @ [V]) y = index Vs y" by(simp)
      thus ?thesis using y y  V by auto
    qed
  next
    fix x
    assume x: "x  index Vs ` (fv exp - {V})"
    thus "x  fv (compE1 (Vs @ [V]) exp) - {length Vs}"
    proof(rule imageE)
      fix y
      assume [simp]: "x = index Vs y"
        and y: "y  fv exp - {V}"
      with fv' have "y  set Vs" "y  V" by auto
      hence "index Vs y = index (Vs @ [V]) y" by simp
      with y have "x  index (Vs @ [V]) ` fv exp" by auto
      thus ?thesis using IH' y  set Vs by simp
    qed
  qed
  thus ?case by simp
next
  case (Synchronized Vs V exp1 exp2)
  have IH1: "fv exp1  set Vs  fv (compE1 Vs exp1) = index Vs ` fv exp1" 
    and IH2: "fv exp2  set (Vs @ [fresh_var Vs])  fv (compE1 (Vs @ [fresh_var Vs]) exp2) = index (Vs @ [fresh_var Vs]) ` fv exp2"
    by fact+
  from ‹fv (syncV (exp1) exp2)  set Vs have fv1: "fv exp1  set Vs"
    and fv2: "fv exp2  set Vs" by auto
  from fv2 have fv2': "fv exp2  set (Vs @ [fresh_var Vs])" by auto
  have "index (Vs @ [fresh_var Vs]) ` fv exp2 = index Vs ` fv exp2"
  proof(rule equalityI[OF subsetI subsetI])
    fix x
    assume x: "x  index (Vs @ [fresh_var Vs]) ` fv exp2"
    thus "x  index Vs ` fv exp2"
    proof(rule imageE)
      fix y
      assume [simp]: "x = index (Vs @ [fresh_var Vs]) y"
        and y: "y  fv exp2"
      from y fv2 have "y  set Vs" by auto
      moreover hence "y  (fresh_var Vs)" by(auto simp add: fresh_var_fresh)
      ultimately show ?thesis using y by(auto)
    qed
  next
    fix x
    assume x: "x  index Vs ` fv exp2"
    thus "x  index (Vs @ [fresh_var Vs]) ` fv exp2"
    proof(rule imageE)
      fix y
      assume [simp]: "x = index Vs y"
        and y: "y  fv exp2"
      from y fv2 have "y  set Vs" by auto
      moreover hence "y  (fresh_var Vs)" by(auto simp add: fresh_var_fresh)
      ultimately have "index Vs y = index (Vs @ [fresh_var Vs]) y" by simp
      thus ?thesis using y by(auto)
    qed
  qed
  with IH1[OF fv1] IH2[OF fv2'] show ?case by(auto)
next
  case (InSynchronized Vs V a exp)
  have IH: "fv exp  set (Vs @ [fresh_var Vs])  fv (compE1 (Vs @ [fresh_var Vs]) exp) = index (Vs @ [fresh_var Vs]) ` fv exp"
    by fact
  from ‹fv (insyncV (a) exp)  set Vs have fv: "fv exp  set Vs" by simp
  hence fv': "fv exp  set (Vs @ [fresh_var Vs])" by auto
  have "index (Vs @ [fresh_var Vs]) ` fv exp = index Vs ` fv exp"
  proof(rule equalityI[OF subsetI subsetI])
    fix x
    assume "x  index (Vs @ [fresh_var Vs]) ` fv exp"
    thus "x  index Vs ` fv exp"
    proof(rule imageE)
      fix y
      assume [simp]: "x = index (Vs @ [fresh_var Vs]) y"
        and y: "y  fv exp"
      from y fv have "y  set Vs" by auto
      moreover hence "y  (fresh_var Vs)" by(auto simp add: fresh_var_fresh)
      ultimately have "index (Vs @ [fresh_var Vs]) y = index Vs y" by simp
      thus ?thesis using y by simp
    qed
  next
    fix x
    assume "x  index Vs ` fv exp"
    thus "x  index (Vs @ [fresh_var Vs]) ` fv exp"
    proof(rule imageE)
      fix y
      assume [simp]: "x = index Vs y"
        and y: "y  fv exp"
      from y fv have "y  set Vs" by auto
      moreover hence "y  (fresh_var Vs)" by(auto simp add: fresh_var_fresh)
      ultimately have "index Vs y = index (Vs @ [fresh_var Vs]) y" by simp
      thus ?thesis using y by auto
    qed
  qed
  with IH[OF fv'] show ?case by simp
next
  case (TryCatch Vs exp1 C V exp2)
  have IH1: "fv exp1  set Vs  fv (compE1 Vs exp1) = index Vs ` fv exp1" 
    and IH2: "fv exp2  set (Vs @ [V])  fv (compE1 (Vs @ [V]) exp2) = index (Vs @ [V]) ` fv exp2"
    by fact+
  from ‹fv (try exp1 catch(C V) exp2)  set Vs have fv1: "fv exp1  set Vs"
    and fv2: "fv exp2  set (Vs @ [V])" by auto
  have "index (Vs @ [V]) ` fv exp2 - {length Vs} = index Vs ` (fv exp2 - {V})" 
  proof(rule equalityI[OF subsetI subsetI])
    fix x
    assume x: "x  index (Vs @ [V]) ` fv exp2 - {length Vs}"
    hence "x  length Vs" by simp
    from x have "x  index (Vs @ [V]) ` fv exp2" by auto
    thus "x  index Vs ` (fv exp2 - {V})"
    proof(rule imageE)
      fix y
      assume [simp]: "x = index (Vs @ [V]) y"
        and y: "y  fv exp2"
      have "y  V"
      proof
        assume [simp]: "y = V"
        hence "x = length Vs" by simp
        with x  length Vs show False by contradiction
      qed
      moreover with fv2 y have "y  set Vs" by auto
      ultimately have "index (Vs @ [V]) y = index Vs y" by(simp)
      thus ?thesis using y y  V by auto
    qed
  next
    fix x
    assume x: "x  index Vs ` (fv exp2 - {V})"
    thus "x  index (Vs @ [V]) ` fv exp2 - {length Vs}"
    proof(rule imageE)
      fix y
      assume [simp]: "x = index Vs y"
        and y: "y  fv exp2 - {V}"
      with fv2 have "y  set Vs" "y  V" by auto
      hence "index Vs y = index (Vs @ [V]) y" by simp
      with y have "x  index (Vs @ [V]) ` fv exp2" by auto
      thus ?thesis using y  set Vs by simp
    qed
  qed
  with IH1[OF fv1] IH2[OF fv2] show ?case by auto
qed(auto)

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows syncvars_compE1: "fv e  set Vs  syncvars (compE1 Vs e)"
  and syncvarss_compEs1: "fvs es  set Vs  syncvarss (compEs1 Vs es)"
proof(induct Vs e and Vs es rule: compE1_compEs1_induct)
  case (Block Vs V ty vo exp)
  from ‹fv {V:ty=vo; exp}  set Vs have "fv exp  set (Vs @ [V])" by auto
  from ‹fv exp  set (Vs @ [V])  syncvars (compE1 (Vs @ [V]) exp)[OF this] show ?case by(simp)
next
  case (Synchronized Vs V exp1 exp2)
  note IH1 = ‹fv exp1  set Vs  syncvars (compE1 Vs exp1)
  note IH2 = ‹fv exp2  set (Vs @ [fresh_var Vs])  syncvars (compE1 (Vs @ [fresh_var Vs]) exp2)
  from ‹fv (syncV (exp1) exp2)  set Vs have fv1: "fv exp1  set Vs"
    and fv2: "fv exp2  set Vs" and fv2': "fv exp2  set (Vs @ [fresh_var Vs])" by auto
  have "length Vs  index (Vs @ [fresh_var Vs]) ` fv exp2"
  proof
    assume "length Vs  index (Vs @ [fresh_var Vs]) ` fv exp2"
    thus False
    proof(rule imageE)
      fix x
      assume x: "length Vs = index (Vs @ [fresh_var Vs]) x"
        and x': "x  fv exp2"
      from x' fv2 have "x  set Vs" "x  (fresh_var Vs)" by(auto simp add: fresh_var_fresh)
      with x show ?thesis by(simp)
    qed
  qed
  with IH1[OF fv1] IH2[OF fv2'] fv2' show ?case by(simp add: fv_compE1)
next
  case (InSynchronized Vs V a exp)
  note IH = ‹fv exp  set (Vs @ [fresh_var Vs])  syncvars (compE1 (Vs @ [fresh_var Vs]) exp)
  from ‹fv (insyncV (a) exp)  set Vs have fv: "fv exp  set Vs"
    and fv': "fv exp  set (Vs @ [fresh_var Vs])" by auto
  have "length Vs  index (Vs @ [fresh_var Vs]) ` fv exp"
  proof
    assume "length Vs  index (Vs @ [fresh_var Vs]) ` fv exp"
    thus False
    proof(rule imageE)
      fix x
      assume x: "length Vs = index (Vs @ [fresh_var Vs]) x"
        and x': "x  fv exp"
      from x' fv have "x  set Vs" "x  (fresh_var Vs)" by(auto simp add: fresh_var_fresh)
      with x show ?thesis by(simp)
    qed
  qed
  with IH[OF fv'] fv' show ?case by(simp add: fv_compE1)
next
  case (TryCatch Vs exp1 C V exp2)
  note IH1 = ‹fv exp1  set Vs  syncvars (compE1 Vs exp1)
  note IH2 = ‹fv exp2  set (Vs @ [V])  syncvars (compE1 (Vs @ [V]) exp2)
  from ‹fv (try exp1 catch(C V) exp2)  set Vs have fv1: "fv exp1  set Vs"
    and fv2: "fv exp2  set (Vs @ [V])" by auto
  from IH1[OF fv1] IH2[OF fv2] show ?case by auto
qed auto

lemma (in heap_base) synthesized_call_compP [simp]:
  "synthesized_call (compP f P) h aMvs = synthesized_call P h aMvs"
by(simp add: synthesized_call_def)


primrec fin1 :: "'addr expr  'addr expr1"
where
  "fin1 (Val v) = Val v"
| "fin1 (throw e) = throw (fin1 e)"

lemma comp_final: "final e  compE1 Vs e = fin1 e"
by(erule finalE, simp_all)

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows [simp]: "max_vars (compE1 Vs e) = max_vars e"
  and "max_varss (compEs1 Vs es) = max_varss es"
by (induct Vs e and Vs es rule: compE1_compEs1_induct)(simp_all)

text‹Compiling programs:›

definition compP1 :: "'addr J_prog  'addr J1_prog"
where
  "compP1    compP (λC M Ts T (pns,body). compE1 (this#pns) body)"

declare compP1_def[simp]

end

Theory J0J1Bisim

(*  Title:      JinjaThreads/Compiler/J0J1Bisim.thy
    Author:     Andreas Lochbihler

    Reminiscent of the Jinja theory Compiler/Correctness1
*)

section ‹The bisimulation relation betwenn source and intermediate language›

theory J0J1Bisim imports
  J1
  J1WellForm
  Compiler1
  "../J/JWellForm"
  J0
begin

subsection‹Correctness of program compilation›

primrec unmod :: "'addr expr1  nat  bool"
  and unmods :: "'addr expr1 list  nat  bool"
where
  "unmod (new C) i = True"
| "unmod (newA Te) i = unmod e i"
| "unmod (Cast C e) i = unmod e i"
| "unmod (e instanceof T) i = unmod e i"
| "unmod (Val v) i = True"
| "unmod (e1 «bop» e2) i = (unmod e1 i  unmod e2 i)"
| "unmod (Var i) j = True"
| "unmod (i:=e) j = (i  j  unmod e j)"
| "unmod (ai) j = (unmod a j  unmod i j)"
| "unmod (ai:=e) j = (unmod a j  unmod i j  unmod e j)"
| "unmod (a∙length) j = unmod a j"
| "unmod (eF{D}) i = unmod e i"
| "unmod (e1F{D}:=e2) i = (unmod e1 i  unmod e2 i)"
| "unmod (e1∙compareAndSwap(DF, e2, e3)) i = (unmod e1 i  unmod e2 i  unmod e3 i)"
| "unmod (eM(es)) i = (unmod e i  unmods es i)"
| "unmod {j:T=vo; e} i = ((i = j  vo = None)  unmod e i)"
| "unmod (syncV (o') e) i = (unmod o' i  unmod e i  i  V)"
| "unmod (insyncV (a) e) i = unmod e i"
| "unmod (e1;;e2) i = (unmod e1 i  unmod e2 i)"
| "unmod (if (e) e1 else e2) i = (unmod e i  unmod e1 i  unmod e2 i)"
| "unmod (while (e) c) i = (unmod e i  unmod c i)"
| "unmod (throw e) i = unmod e i"
| "unmod (try e1 catch(C i) e2) j = (unmod e1 j  (if i=j then False else unmod e2 j))"

| "unmods ([]) i = True"
| "unmods (e#es) i = (unmod e i  unmods es i)"

lemma unmods_map_Val [simp]: "unmods (map Val vs) V"
by(induct vs) simp_all

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows hidden_unmod: "hidden Vs i  unmod (compE1 Vs e) i"
  and hidden_unmods: "hidden Vs i  unmods (compEs1 Vs es) i"
apply(induct Vs e and Vs es rule: compE1_compEs1_induct)
apply (simp_all add:hidden_inacc)
apply(auto simp add:hidden_def)
done

lemma unmod_extRet2J [simp]: "unmod e i  unmod (extRet2J e va) i"
by(cases va) simp_all

lemma max_dest: "(n :: nat) + max a b  c  n + a  c  n + b  c"
apply(auto simp add: max_def split: if_split_asm) 
done

declare max_dest [dest!]

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows fv_unmod_compE1: " i < length Vs; Vs ! i  fv e   unmod (compE1 Vs e) i"
  and fvs_unmods_compEs1: " i < length Vs; Vs ! i  fvs es   unmods (compEs1 Vs es) i"
proof(induct Vs e and Vs es rule: compE1_compEs1_induct)
  case (Block Vs V ty vo exp)
  note IH = i < length (Vs @ [V]); (Vs @ [V]) ! i  fv exp   unmod (compE1 (Vs @ [V]) exp) i
  note len = i < length Vs
  hence i: "i < length (Vs @ [V])" by simp
  show ?case
  proof(cases "Vs ! i = V")
    case True
    from len have "hidden (Vs @ [Vs ! i]) i" by(rule hidden_snoc_nth)
    with len True show ?thesis by(auto intro: hidden_unmod)
  next
    case False
    with Vs ! i  fv {V:ty=vo; exp} len have "(Vs @ [V]) ! i  fv exp"
      by(auto simp add: nth_append)
    from IH[OF i this] len show ?thesis by(auto)
  qed
next
  case (TryCatch Vs e1 C V e2)
  note IH1 = i < length Vs; Vs ! i  fv e1   unmod (compE1 Vs e1) i
  note IH2 = i < length (Vs @ [V]); (Vs @ [V]) ! i  fv e2   unmod (compE1 (Vs @ [V]) e2) i
  note len = i < length Vs
  hence i: "i < length (Vs @ [V])" by simp
  have "unmod (compE1 (Vs @ [V]) e2) i"
  proof(cases "Vs ! i = V")
    case True
    from len have "hidden (Vs @ [Vs ! i]) i" by(rule hidden_snoc_nth)
    with len True show ?thesis by(auto intro: hidden_unmod)
  next
    case False
    with Vs ! i  fv (try e1 catch(C V) e2) len have "(Vs @ [V]) ! i  fv e2"
      by(auto simp add: nth_append)
    from IH2[OF i this] len show ?thesis by(auto)
  qed
  with IH1[OF len] Vs ! i  fv (try e1 catch(C V) e2) len show ?case by(auto)
qed(auto dest: index_le_lengthD simp add: nth_append)

lemma hidden_lengthD: "hidden Vs i  i < length Vs"
by(simp add: hidden_def)

lemma fixes e :: "'addr expr1" and es :: "'addr expr1 list"
  shows fv_B_unmod: " V  fv e;e n; V < n   unmod e V"
  and fvs_Bs_unmods: " V  fvs es; ℬs es n; V < n   unmods es V"
by(induct e and es arbitrary: n and n rule: unmod.induct unmods.induct) auto

lemma assumes fin: "final e'"
  shows unmod_inline_call: "unmod (inline_call e' e) V  unmod e V"
  and unmods_inline_calls: "unmods (inline_calls e' es) V  unmods es V"
apply(induct e and es rule: unmod.induct unmods.induct)
apply(insert fin)
apply(auto simp add: is_vals_conv)
done

subsection ‹The delay bisimulation relation›

text ‹Delay bisimulation for expressions›

inductive bisim :: "vname list  'addr expr  'addr expr1  'addr val list  bool"
  and bisims :: "vname list  'addr expr list  'addr expr1 list  'addr val list  bool"
where
  bisimNew: "bisim Vs (new C) (new C) xs"
| bisimNewArray: "bisim Vs e e' xs  bisim Vs (newA Te) (newA Te') xs"
| bisimCast: "bisim Vs e e' xs  bisim Vs (Cast T e) (Cast T e') xs"
| bisimInstanceOf: "bisim Vs e e' xs  bisim Vs (e instanceof T) (e' instanceof T) xs"
| bisimVal: "bisim Vs (Val v) (Val v) xs"
| bisimBinOp1:
  " bisim Vs e e' xs; ¬ is_val e; ¬ contains_insync e''   bisim Vs (e «bop» e'') (e' «bop» compE1 Vs e'') xs"
| bisimBinOp2: "bisim Vs e e' xs  bisim Vs (Val v «bop» e) (Val v «bop» e') xs"
| bisimVar: "bisim Vs (Var V) (Var (index Vs V)) xs"
| bisimLAss: "bisim Vs e e' xs  bisim Vs (V:=e) (index Vs V:=e') xs"
| bisimAAcc1: " bisim Vs a a' xs; ¬ is_val a; ¬ contains_insync i   bisim Vs (ai) (a'compE1 Vs i) xs"
| bisimAAcc2: "bisim Vs i i' xs  bisim Vs (Val vi) (Val vi') xs"
| bisimAAss1:
  " bisim Vs a a' xs; ¬ is_val a; ¬ contains_insync i; ¬ contains_insync e 
   bisim Vs (ai:=e) (a'compE1 Vs i:=compE1 Vs e) xs"
| bisimAAss2: " bisim Vs i i' xs; ¬ is_val i; ¬ contains_insync e   bisim Vs (Val vi:=e) (Val vi':=compE1 Vs e) xs"
| bisimAAss3: "bisim Vs e e' xs  bisim Vs (Val vVal i := e) (Val vVal i := e') xs"
| bisimALength: "bisim Vs a a' xs  bisim Vs (a∙length) (a'∙length) xs"
| bisimFAcc: "bisim Vs e e' xs  bisim Vs (eF{D}) (e'F{D}) xs"
| bisimFAss1: " bisim Vs e e' xs; ¬ is_val e; ¬ contains_insync e''   bisim Vs (eF{D}:=e'') (e'F{D}:=compE1 Vs e'') xs"
| bisimFAss2: "bisim Vs e e' xs  bisim Vs (Val vF{D} := e) (Val vF{D} := e') xs"
| bisimCAS1: " bisim Vs e e' xs; ¬ is_val e; ¬ contains_insync e2; ¬ contains_insync e3  
   bisim Vs (e∙compareAndSwap(DF, e2, e3)) (e'∙compareAndSwap(DF, compE1 Vs e2, compE1 Vs e3)) xs"
| bisimCAS2: " bisim Vs e e' xs; ¬ is_val e; ¬ contains_insync e3  
   bisim Vs (Val v∙compareAndSwap(DF, e, e3)) (Val v∙compareAndSwap(DF, e', compE1 Vs e3)) xs"
| bisimCAS3: "bisim Vs e e' xs  bisim Vs (Val v∙compareAndSwap(DF, Val v', e)) (Val v∙compareAndSwap(DF, Val v', e')) xs"
| bisimCallObj: " bisim Vs e e' xs; ¬ is_val e; ¬ contains_insyncs es   bisim Vs (eM(es)) (e'M(compEs1 Vs es)) xs"
| bisimCallParams: "bisims Vs es es' xs  bisim Vs (Val vM(es)) (Val vM(es')) xs"
| bisimBlockNone: "bisim (Vs@[V]) e e' xs  bisim Vs {V:T=None; e} {(length Vs):T=None; e'} xs"
| bisimBlockSome: " bisim (Vs@[V]) e e' (xs[length Vs := v])   bisim Vs {V:T=v; e} {(length Vs):T=v; e'} xs"
| bisimBlockSomeNone: " bisim (Vs@[V]) e e' xs; xs ! (length Vs) = v   bisim Vs {V:T=v; e} {(length Vs):T=None; e'} xs"
| bisimSynchronized:
  " bisim Vs o' o'' xs; ¬ contains_insync e 
   bisim Vs (sync(o') e) (synclength Vs(o'') (compE1 (Vs@[fresh_var Vs]) e)) xs"
| bisimInSynchronized:
  " bisim (Vs@[fresh_var Vs]) e e' xs; xs ! length Vs = Addr a   bisim Vs (insync(a) e) (insynclength Vs(a) e') xs"
| bisimSeq: " bisim Vs e e' xs; ¬ contains_insync e''   bisim Vs (e;;e'') (e';;compE1 Vs e'') xs"
| bisimCond:
  " bisim Vs e e' xs; ¬ contains_insync e1; ¬ contains_insync e2 
   bisim Vs (if (e) e1 else e2) (if (e') (compE1 Vs e1) else (compE1 Vs e2)) xs"
| bisimWhile:
  " ¬ contains_insync b; ¬ contains_insync e   bisim Vs (while (b) e) (while (compE1 Vs b) (compE1 Vs e)) xs"
| bisimThrow: "bisim Vs e e' xs  bisim Vs (throw e) (throw e') xs"
| bisimTryCatch:
  " bisim Vs e e' xs; ¬ contains_insync e'' 
   bisim Vs (try e catch(C V) e'') (try e' catch(C (length Vs)) compE1 (Vs@[V]) e'') xs"

| bisimsNil: "bisims Vs [] [] xs"
| bisimsCons1: " bisim Vs e e' xs; ¬ is_val e; ¬ contains_insyncs es   bisims Vs (e # es) (e' # compEs1 Vs es) xs"
| bisimsCons2: "bisims Vs es es' xs  bisims Vs (Val v # es) (Val v # es') xs"

declare bisimNew [iff]
declare bisimVal [iff]
declare bisimVar [iff]
declare bisimWhile [iff]
declare bisimsNil [iff]

declare bisim_bisims.intros [intro!]
declare bisimsCons1 [rule del, intro] bisimsCons2 [rule del, intro]
  bisimBinOp1 [rule del, intro] bisimAAcc1 [rule del, intro]
  bisimAAss1 [rule del, intro] bisimAAss2 [rule del, intro]
  bisimFAss1 [rule del, intro]
  bisimCAS1 [rule del, intro] bisimCAS2 [rule del, intro]
  bisimCallObj [rule del, intro] 

inductive_cases bisim_safe_cases [elim!]:
  "bisim Vs (new C) e' xs"
  "bisim Vs (newA Te) e' xs"
  "bisim Vs (Cast T e) e' xs"
  "bisim Vs (e instanceof T) e' xs"
  "bisim Vs (Val v) e' xs"
  "bisim Vs (Var V) e' xs"
  "bisim Vs (V:=e) e' xs"
  "bisim Vs (Val vi) e' xs"
  "bisim Vs (Val vVal v' := e) e' xs"
  "bisim Vs (Val v∙compareAndSwap(DF, Val v', e)) e' xs"
  "bisim Vs (a∙length) e' xs"
  "bisim Vs (eF{D}) e' xs"
  "bisim Vs (sync(o') e) e' xs"
  "bisim Vs (insync(a) e) e' xs"
  "bisim Vs (e;;e') e'' xs"
  "bisim Vs (if (b) e1 else e2) e' xs"
  "bisim Vs (while (b) e) e' xs"
  "bisim Vs (throw e) e' xs"
  "bisim Vs (try e catch(C V) e') e'' xs"
  "bisim Vs e' (new C) xs"
  "bisim Vs e' (newA Te) xs"
  "bisim Vs e' (Cast T e) xs"
  "bisim Vs e' (e instanceof T) xs"
  "bisim Vs e' (Val v) xs"
  "bisim Vs e' (Var V) xs"
  "bisim Vs e' (V:=e) xs"
  "bisim Vs e' (Val vi) xs"
  "bisim Vs e' (Val vVal v' := e) xs"
  "bisim Vs e' (Val v∙compareAndSwap(DF, Val v', e)) xs"
  "bisim Vs e' (a∙length) xs"
  "bisim Vs e' (eF{D}) xs"
  "bisim Vs e' (syncV (o') e) xs"
  "bisim Vs e' (insyncV (a) e) xs"
  "bisim Vs e'' (e;;e') xs"
  "bisim Vs e' (if (b) e1 else e2) xs"
  "bisim Vs e' (while (b) e) xs"
  "bisim Vs e' (throw e) xs"
  "bisim Vs e'' (try e catch(C V) e') xs"

inductive_cases bisim_cases [elim]:
  "bisim Vs (e1 «bop» e2) e' xs"
  "bisim Vs (ai) e' xs"
  "bisim Vs (ai:=e) e' xs"
  "bisim Vs (eF{D}:=e') e'' xs"
  "bisim Vs (e∙compareAndSwap(DF, e', e'')) e''' xs"
  "bisim Vs (eM(es)) e' xs"
  "bisim Vs {V:T=vo; e} e' xs"
  "bisim Vs e' (e1 «bop» e2) xs"
  "bisim Vs e' (ai) xs"
  "bisim Vs e' (ai:=e) xs"
  "bisim Vs e'' (eF{D}:=e') xs"
  "bisim Vs e''' (e∙compareAndSwap(DF, e', e'')) xs"
  "bisim Vs e' (eM(es)) xs"
  "bisim Vs e' {V:T=vo; e} xs"

inductive_cases bisims_safe_cases [elim!]:
  "bisims Vs [] es xs"
  "bisims Vs es [] xs"

inductive_cases bisims_cases [elim]:
  "bisims Vs (e # es) es' xs"
  "bisims Vs es' (e # es) xs"

text ‹Delay bisimulation for call stacks›

inductive bisim01 :: "'addr expr  'addr expr1 × 'addr locals1  bool"
where
  " bisim [] e e' xs; fv e = {}; 𝒟 e {}; max_vars e'  length xs; call e = aMvs; call1 e' = aMvs 
   bisim01 e (e', xs)"

inductive bisim_list :: "'addr expr list  ('addr expr1 × 'addr locals1) list  bool"
where
  bisim_listNil: "bisim_list [] []"
| bisim_listCons: 
  " bisim_list es exs'; bisim [] e e' xs; 
     fv e = {}; 𝒟 e {};
     max_vars e'  length xs;
     call e = aMvs; call1 e' = aMvs 
   bisim_list (e # es) ((e', xs) # exs')"

inductive_cases bisim_list_cases [elim!]:
 "bisim_list [] exs'"
 "bisim_list (ex # exs) exs'"
 "bisim_list exs (ex' # exs')"

fun bisim_list1 :: 
  "'addr expr × 'addr expr list  ('addr expr1 × 'addr locals1) × ('addr expr1 × 'addr locals1) list  bool"
where
  "bisim_list1 (e, es) ((e1, xs1), exs1)  
   bisim_list es exs1  bisim [] e e1 xs1  fv e = {}  𝒟 e {}  max_vars e1  length xs1"

definition bisim_red0_Red1 :: 
  "(('addr expr × 'addr expr list) × 'heap)
   ((('addr expr1 × 'addr locals1) × ('addr expr1 × 'addr locals1) list) × 'heap)  bool"
where "bisim_red0_Red1  (λ(es, h) (exs, h'). bisim_list1 es exs  h = h')"

abbreviation ta_bisim01 ::
  "('addr, 'thread_id, 'heap) J0_thread_action  ('addr, 'thread_id, 'heap) J1_thread_action  bool" 
where
  "ta_bisim01  ta_bisim (λt. bisim_red0_Red1)"

definition bisim_wait01 ::
  "('addr expr × 'addr expr list)  ('addr expr1 × 'addr locals1) × ('addr expr1 × 'addr locals1) list  bool"
where "bisim_wait01  λ(e0, es0) ((e1, xs1), exs1). call e0  None  call1 e1  None"

lemma bisim_list1I[intro?]:
  " bisim_list es exs1; bisim [] e e1 xs1; fv e = {};
     𝒟 e {}; max_vars e1  length xs1 
   bisim_list1 (e, es) ((e1, xs1), exs1)"
by simp

lemma bisim_list1E[elim?]:
  assumes "bisim_list1 (e, es) ((e1, xs1), exs1)"
  obtains "bisim_list es exs1" "bisim [] e e1 xs1" "fv e = {}" "𝒟 e {}" "max_vars e1  length xs1"
using assms by auto

lemma bisim_list1_elim:
  assumes "bisim_list1 es' exs"
  obtains e es e1 xs1 exs1
  where "es' = (e, es)" "exs = ((e1, xs1), exs1)"
  and "bisim_list es exs1" "bisim [] e e1 xs1" "fv e = {}" "𝒟 e {}" "max_vars e1  length xs1"
using assms by(cases es')(cases exs, fastforce)

declare bisim_list1.simps [simp del]


lemma bisims_map_Val_conv [simp]: "bisims Vs (map Val vs) es xs = (es = map Val vs)"
apply(induct vs arbitrary: es)
 apply(fastforce)
apply(simp)
apply(rule iffI)
apply(erule bisims_cases, auto)
done

declare compEs1_conv_map [simp del]

lemma bisim_contains_insync: "bisim Vs e e' xs  contains_insync e = contains_insync e'"
  and bisims_contains_insyncs: "bisims Vs es es' xs  contains_insyncs es = contains_insyncs es'"
by(induct rule: bisim_bisims.inducts)(auto)

lemma bisims_map_Val_Throw: 
  "bisims Vs (map Val vs @ Throw a # es) es' xs  es' = map Val vs @ Throw a # compEs1 Vs es  ¬ contains_insyncs es"
apply(induct vs arbitrary: es')
 apply(simp)
 apply(fastforce simp add: compEs1_conv_map)
apply(fastforce elim!: bisims_cases intro: bisimsCons2)
done

lemma compE1_bisim [intro]: " fv e  set Vs; ¬ contains_insync e   bisim Vs e (compE1 Vs e) xs"
  and compEs1_bisims [intro]: " fvs es  set Vs; ¬ contains_insyncs es   bisims Vs es (compEs1 Vs es) xs"
proof(induct Vs e and Vs es arbitrary: xs and xs rule: compE1_compEs1_induct)
  case (BinOp Vs exp1 bop exp2 x)
  thus ?case by(cases "is_val exp1")(auto)
next
  case (AAcc Vs exp1 exp2 x)
  thus ?case by(cases "is_val exp1")(auto)
next
  case (AAss Vs exp1 exp2 exp3 x)
  thus ?case by(cases "is_val exp1", cases "is_val exp2", fastforce+)
next
  case (FAss Vs exp1 F D exp2 x)
  thus ?case by(cases "is_val exp1", auto)
next
  case (CAS Vs e1 D F e2 e3 x)
  thus ?case by(cases "is_val e1", cases "is_val e2", fastforce+)
next
  case (Call Vs obj M params x)
  thus ?case by(cases "is_val obj")(auto)
next
  case (Block Vs V T vo exp xs)
  from ‹fv {V:T=vo; exp}  set Vs have "fv exp  set (Vs@[V])" by(auto)
  with Block show ?case by(cases vo)(auto)
next
  case (Cons Vs exp list x)
  thus ?case by(cases "is_val exp")(auto intro!: bisimsCons2)
qed(auto)

lemma bisim_hidden_unmod: " bisim Vs e e' xs; hidden Vs i   unmod e' i"
  and bisims_hidden_unmods: " bisims Vs es es' xs; hidden Vs i   unmods es' i"
by(induct rule: bisim_bisims.inducts)(auto intro: hidden_unmod hidden_unmods dest: hidden_inacc hidden_lengthD)

lemma bisim_fv_unmod: " bisim Vs e e' xs; i < length Vs; Vs ! i  fv e   unmod e' i"
  and bisims_fvs_unmods: " bisims Vs es es' xs; i < length Vs; Vs ! i  fvs es   unmods es' i"
proof(induct rule: bisim_bisims.inducts)
  case (bisimBlockNone Vs V e e' xs T)
  note len = i < length Vs
  have "unmod e' i"
  proof(cases "Vs ! i = V")
    case True
    from len have "hidden (Vs @ [Vs ! i]) i" by(rule hidden_snoc_nth)
    with len True ‹bisim (Vs @ [V]) e e' xs show ?thesis by(auto intro: bisim_hidden_unmod)
  next
    case False
    with bisimBlockNone show ?thesis by(auto simp add: nth_append)
  qed
  thus ?case by simp
next
  case (bisimBlockSome Vs V e e' xs v T)
  note len = i < length Vs
  show ?case
  proof(cases "Vs ! i = V")
    case True
    from len have "hidden (Vs @ [Vs ! i]) i" by(rule hidden_snoc_nth)
    with len True ‹bisim (Vs @ [V]) e e' (xs[length Vs := v])
    show ?thesis by(auto intro: bisim_hidden_unmod)
  next
    case False
    with bisimBlockSome show ?thesis by(auto simp add: nth_append)
  qed
next
  case (bisimBlockSomeNone Vs V e e' xs v T)
  note len = i < length Vs
  show ?case
  proof(cases "Vs ! i = V")
    case True
    from len have "hidden (Vs @ [Vs ! i]) i" by(rule hidden_snoc_nth)
    with len True ‹bisim (Vs @ [V]) e e' xs
    show ?thesis by(auto intro: bisim_hidden_unmod)
  next
    case False
    with bisimBlockSomeNone show ?thesis by(auto simp add: nth_append)
  qed
qed(fastforce dest: fv_unmod_compE1 fvs_unmods_compEs1 index_le_lengthD simp add: nth_append)+

lemma bisim_extRet2J [intro!]: "bisim Vs e e' xs  bisim Vs (extRet2J e va) (extRet2J1 e' va) xs"
by(cases va) auto

lemma bisims_map_Val_conv2 [simp]: "bisims Vs es (map Val vs) xs = (es = map Val vs)"
apply(induct vs arbitrary: es)
apply(fastforce elim!: bisims_cases)+
done

lemma bisims_map_Val_Throw2: 
  "bisims Vs es' (map Val vs @ Throw a # es) xs 
   (es''. es' = map Val vs @ Throw a # es''  es = compEs1 Vs es''  ¬ contains_insyncs es'')"
apply(induct vs arbitrary: es')
 apply(simp)
 apply(fastforce simp add: compEs1_conv_map)
apply(fastforce elim!: bisims_cases)
done

lemma hidden_bisim_unmod: " bisim Vs e e' xs; hidden Vs i   unmod e' i"
  and hidden_bisims_unmods: " bisims Vs es es' xs; hidden Vs i   unmods es' i"
apply(induct rule: bisim_bisims.inducts)
apply(auto simp add:hidden_inacc intro: hidden_unmod hidden_unmods)
apply(auto simp add: hidden_def)
done

lemma bisim_list_list_all2_conv:
  "bisim_list es exs'  list_all2 bisim01 es exs'"
proof
  assume "bisim_list es exs'"
  thus "list_all2 bisim01 es exs'"
    by induct(auto intro!: bisim01.intros)
next
  assume "list_all2 bisim01 es exs'"
  thus "bisim_list es exs'"
    by(induct es arbitrary: exs')(auto intro!: bisim_listCons bisim_listNil elim!: bisim01.cases simp add: list_all2_Cons1)
qed

lemma bisim_list_extTA2J0_extTA2J1:
  assumes wf: "wf_J_prog P"
  and sees: "P  C sees M:[]T = meth in D"
  shows "bisim_list1 (extNTA2J0 P (C, M, a)) (extNTA2J1 (compP1 P) (C, M, a))"
proof -
  obtain pns body where "meth = (pns, body)" by(cases meth)
  with sees have sees: "P  C sees M:[]T = (pns, body) in D" by simp
  moreover let ?xs = "Addr a # replicate (max_vars body) undefined_value"
  let ?e' = "{0:Class D=None; compE1 (this # pns) body}"
  have "bisim_list1 ({this:Class D=Addr a; body}, []) ((?e', ?xs), [])"
  proof
    show "bisim_list [] []" ..
    from sees_wf_mdecl[OF wf_prog_wwf_prog[OF wf] sees] have "fv body  set [this]" "pns = []"
      by(auto simp add: wf_mdecl_def)
    thus "fv ({this:Class D=Addr a; body}) = {}" by simp
    from sees_wf_mdecl[OF wf sees] obtain T' where "P,[this  Class D]  body :: T'" "this  set pns"
      and "𝒟 body dom [this  Addr a]" by(auto simp add: wf_mdecl_def)
    hence "¬ contains_insync body" by(auto simp add: contains_insync_conv dest: WT_expr_locks)
    with ‹fv body  set [this]
    have "bisim ([] @ [this]) body (compE1 (this # pns) body) ?xs"
      unfolding append.simps pns = [] by(rule compE1_bisim)
    hence "bisim [] {this:Class D=Addr a; body} {length ([] :: String.literal list):Class D=None; compE1 (this # pns) body} ?xs"
      by(rule bisimBlockSomeNone)(simp)
    thus "bisim [] ({this:Class D=Addr a; body}) ?e' ?xs" by simp
    from ‹𝒟 body dom [this  Addr a] show "𝒟 ({this:Class D=Addr a; body}) {}" by simp
    show "max_vars ?e'  length ?xs" by simp
  qed
  ultimately show ?thesis by(simp)
qed


lemma bisim_max_vars: "bisim Vs e e' xs  max_vars e = max_vars e'"
  and bisims_max_varss: "bisims Vs es es' xs  max_varss es = max_varss es'"
apply(induct rule: bisim_bisims.inducts)
apply(auto simp add: max_vars_compE1 max_varss_compEs1)
done

lemma bisim_call: "bisim Vs e e' xs  call e = call e'"
  and bisims_calls: "bisims Vs es es' xs  calls es = calls es'"
apply(induct rule: bisim_bisims.inducts)
apply(auto simp add: is_vals_conv)
done

lemma bisim_call_None_call1: " bisim Vs e e' xs; call e = None   call1 e' = None"
  and bisims_calls_None_calls1: " bisims Vs es es' xs; calls es = None   calls1 es' = None"
by(induct rule: bisim_bisims.inducts)(auto simp add: is_vals_conv split: if_split_asm)

lemma bisim_call1_Some_call:
  " bisim Vs e e' xs; call1 e' = aMvs   call e = aMvs"

  and bisims_calls1_Some_calls:
  " bisims Vs es es' xs; calls1 es' = aMvs   calls es = aMvs"
by(induct rule: bisim_bisims.inducts)(auto simp add: is_vals_conv split: if_split_asm)

lemma blocks_bisim: 
  assumes bisim: "bisim (Vs @ pns) e e' xs"
  and length: "length vs = length pns" "length Ts = length pns"
  and xs: "i. i < length vs  xs ! (i + length Vs) = vs ! i"
  shows "bisim Vs (blocks pns Ts vs e) (blocks1 (length Vs) Ts e') xs"
using bisim length xs
proof(induct pns Ts vs e arbitrary: e' Vs rule: blocks.induct)
  case (1 V Vs T Ts v vs e e' VS)
  note IH = e' Vsa. bisim (Vsa @ Vs) e e' xs;
                       length vs = length Vs; length Ts = length Vs; i<length vs. xs ! (i + length Vsa) = vs ! i
            bisim Vsa (blocks Vs Ts vs e) (blocks1 (length Vsa) Ts e') xs
  note xs = i<length (v # vs). xs ! (i + length VS) = (v # vs) ! i
  hence xs': "i<length vs. xs ! (i + length (VS @ [V])) = vs ! i" and v: "xs ! length VS = v" by(auto)
  from ‹bisim (VS @ V # Vs) e e' xs have "bisim ((VS @ [V]) @ Vs) e e' xs" by simp
  from IH[OF this _ _ xs'] ‹length (v # vs) = length (V # Vs) ‹length (T # Ts) = length (V # Vs)
  have "bisim (VS @ [V]) (blocks Vs Ts vs e) (blocks1 (length (VS @ [V])) Ts e') xs"
    by auto
  hence "bisim VS ({V:T=v; blocks Vs Ts vs e}) {length VS:T=None; blocks1 (length (VS @ [V])) Ts e'} xs"
    using v by(rule bisimBlockSomeNone)
  thus ?case by simp
qed(auto)

lemma fixes e :: "('a,'b,'addr) exp" and es :: "('a,'b,'addr) exp list"
  shows inline_call_max_vars: "call e = aMvs  max_vars (inline_call e' e)  max_vars e + max_vars e'"
  and inline_calls_max_varss: "calls es = aMvs  max_varss (inline_calls e' es)  max_varss es + max_vars e'"
by(induct e and es rule: call.induct calls.induct)(auto)

lemma assumes "final E" "bisim VS E E' xs"
  shows inline_call_compE1: "call e = aMvs  inline_call E' (compE1 Vs e) = compE1 Vs (inline_call E e)"
  and inline_calls_compEs1: "calls es = aMvs  inline_calls E' (compEs1 Vs es) = compEs1 Vs (inline_calls E es)"
proof(induct Vs e and Vs es rule: compE1_compEs1_induct)
  case (Call Vs obj M params)
  note IHobj = ‹call obj = aMvs  inline_call E' (compE1 Vs obj) = compE1 Vs (inline_call E obj)
  note IHparams = ‹calls params = aMvs  inline_calls E' (compEs1 Vs params) = compEs1 Vs (inline_calls E params)
  obtain a M' vs where [simp]: "aMvs = (a, M', vs)" by (cases aMvs, auto)
  with ‹call (objM(params)) = aMvs have "call (objM(params)) = (a, M', vs)" by simp
  thus ?case
  proof(induct rule: call_callE)
    case CallObj
    with IHobj have "inline_call E' (compE1 Vs obj) = compE1 Vs (inline_call E obj)" by auto
    with CallObj show ?case by auto
  next
    case (CallParams v)
    with IHparams have "inline_calls E' (compEs1 Vs params) = compEs1 Vs (inline_calls E params)" by auto
    with CallParams show ?case by(auto simp add: is_vals_conv)
  next
    case Call
    with ‹final E ‹bisim VS E E' xs show ?case by(auto simp add: is_vals_conv)
  qed
qed(auto split: if_split_asm)

lemma assumes bisim: "bisim VS E E' XS"
  and final: "final E"
  shows bisim_inline_call:
  " bisim Vs e e' xs; call e = aMvs; fv e  set Vs 
   bisim Vs (inline_call E e) (inline_call E' e') xs"
  
  and bisims_inline_calls: 
  " bisims Vs es es' xs; calls es = aMvs; fvs es  set Vs 
   bisims Vs (inline_calls E es) (inline_calls E' es') xs"
proof(induct rule: bisim_bisims.inducts)
  case (bisimBinOp1 Vs e e' xs bop e'')
  thus ?case by(cases "is_val (inline_call E e)")(fastforce)+
next
  case (bisimAAcc1 Vs a a' xs i)
  thus ?case by(cases "is_val (inline_call E a)")(fastforce)+
next
  case (bisimAAss1 Vs a a' xs i e)
  thus ?case by(cases "is_val (inline_call E a)", cases "is_val i")(fastforce)+
next
  case (bisimAAss2 Vs i i' xs a e)
  thus ?case by(cases "is_val (inline_call E i)")(fastforce)+
next
  case (bisimFAss1 Vs e e' xs F D e'')
  thus ?case by(cases "is_val (inline_call E e)")(fastforce)+
next
  case (bisimCAS1 Vs e e' xs e2 e3 D F)
  thus ?case 
    apply(cases "is_val (inline_call E e)")
     apply(cases "is_val e2")
      apply(fastforce)
     apply clarsimp
     apply(safe; clarsimp?)
     apply auto
    done
next
  case (bisimCAS2 Vs e e' xs e3 v D F)
  thus ?case by(cases "is_val (inline_call E e)"; safe?; clarsimp; fastforce)
next
  case (bisimCallObj Vs e e' xs es M)
  obtain a M' vs where "aMvs = (a, M', vs)" by(cases aMvs, auto)
  with ‹call (eM(es)) = aMvs have "call (eM(es)) = (a, M', vs)"  by simp
  thus ?case
  proof(induct rule: call_callE)
    case CallObj
    with ‹fv (eM(es))  set Vs aMvs = (a, M', vs)
      call e = aMvs; fv e  set Vs  bisim Vs (inline_call E e) (inline_call E' e') xs
    have IH': "bisim Vs (inline_call E e) (inline_call E' e') xs" by(auto)
    with ‹bisim Vs e e' xs ‹fv (eM(es))  set Vs CallObj ¬ contains_insyncs es show ?thesis
      by(cases "is_val (inline_call E e)")(fastforce)+
  next
    case (CallParams v)
    hence "inline_calls E' (compEs1 Vs es) = compEs1 Vs (inline_calls E es)"
      by -(rule inline_calls_compEs1[OF final bisim])
    moreover from ‹fv (eM(es))  set Vs final fvs_inline_calls[of E es]
    have "fvs (inline_calls E es)  set Vs" by(auto elim!: final.cases)
    moreover note CallParams ‹bisim Vs e e' xs ‹fv (eM(es))  set Vs ¬ contains_insyncs es final
    ultimately show ?case by(auto simp add: is_vals_conv final_iff)
  next
    case Call
    with final bisim ‹bisim Vs e e' xs show ?case by(auto simp add: is_vals_conv)
  qed
next
  case (bisimCallParams Vs es es' xs v M)
  obtain a M' vs where [simp]: "aMvs = (a, M', vs)" by(cases aMvs, auto)
  with ‹call (Val vM(es)) = aMvs have "call (Val vM(es)) = (a, M', vs)"  by simp
  thus ?case
  proof(induct rule: call_callE)
    case CallObj thus ?case by simp
  next
    case (CallParams v')
    with calls es = aMvs; fvs es  set Vs  bisims Vs (inline_calls E es) (inline_calls E' es') xs ‹fv (Val vM(es))  set Vs
    have "bisims Vs (inline_calls E es) (inline_calls E' es') xs" by(auto)
    with final bisim ‹bisims Vs es es' xs show ?case by(auto simp add: is_vals_conv)
  next
    case Call
    with final bisim ‹bisims Vs es es' xs show ?case by(auto)
  qed
next
  case (bisimsCons1 Vs e e' xs es)
  thus ?case by(cases "is_val (inline_call E e)")(fastforce)+
qed(fastforce)+

declare hyperUn_ac [simp del]

lemma sqInt_lem3: " A  A'; B  B'   A  B  A'  B'"
by(auto simp add: hyperset_defs)

lemma sqUn_lem3: " A  A'; B  B'   A  B  A'  B'"
by(auto simp add: hyperset_defs)

lemma A_inline_call: "call e = aMvs  𝒜 e  𝒜 (inline_call e' e)"
  and As_inline_calls: "calls es = aMvs   𝒜s es  𝒜s (inline_calls e' es)"
proof(induct e and es rule: call.induct calls.induct)
  case (Call obj M params)
  obtain a M' vs where [simp]: "aMvs = (a, M', vs)" by(cases aMvs, auto)
  with ‹call (objM(params)) = aMvs have "call (objM(params)) = (a, M', vs)"  by simp
  thus ?case
  proof(induct rule: call_callE)
    case CallObj
    with ‹call obj = aMvs  𝒜 obj  𝒜 (inline_call e' obj)
    show ?case by(auto intro: sqUn_lem)
  next
    case CallParams
    with ‹calls params = aMvs  𝒜s params  𝒜s (inline_calls e' params)
    show ?case by(auto intro: sqUn_lem)
  next
    case Call
    thus ?case by(auto simp add: hyperset_defs)
  qed
next
  case Block thus ?case by(fastforce intro: diff_lem)
next
  case throw thus ?case by(simp add: hyperset_defs)
next
  case TryCatch thus ?case by(auto intro: sqInt_lem)
qed(fastforce intro: sqUn_lem sqUn_lem2)+

lemma assumes "final e'"
  shows defass_inline_call: " call e = aMvs; 𝒟 e A   𝒟 (inline_call e' e) A"
  and defasss_inline_calls: " calls es = aMvs; 𝒟s es A   𝒟s (inline_calls e' es) A"
proof(induct e and es arbitrary: A and A rule: call.induct calls.induct)
  case (Call obj M params A)
  obtain a M' vs where [simp]: "aMvs = (a, M', vs)" by(cases aMvs, auto)
  with ‹call (objM(params)) = aMvs have "call (objM(params)) = (a, M', vs)"  by simp
  thus ?case
  proof(cases rule: call_callE)
    case CallObj
    with ‹𝒟 (objM(params)) A call obj = aMvs; 𝒟 obj A  𝒟 (inline_call e' obj) A
    have "𝒟 (inline_call e' obj) A" by simp
    moreover from A_inline_call[OF CallObj, of e']
    have "A  (𝒜 obj)  A  (𝒜 (inline_call e' obj))" by(rule sqUn_lem2)
    with ‹𝒟 (objM(params)) A have "𝒟s params (A  𝒜 (inline_call e' obj))" by(auto elim: Ds_mono')
    ultimately show ?thesis using CallObj by auto
  next
    case (CallParams v)
    with ‹𝒟 (objM(params)) A calls params = aMvs; 𝒟s params A  𝒟s (inline_calls e' params) A
    have "𝒟s (inline_calls e' params) A" by(simp)
    with CallParams show ?thesis by(auto)
  next
    case Call
    with ‹final e' show ?thesis by(auto elim!: D_mono' simp add: hyperset_defs)
  qed
next
  case (Cons_exp exp exps A)
  show ?case
  proof(cases "is_val exp")
    case True
    with ‹𝒟s (exp # exps) A calls exps = aMvs; 𝒟s exps A  𝒟s (inline_calls e' exps) A 
      ‹calls (exp # exps) = aMvs
    have "𝒟s (inline_calls e' exps) A" by(auto)
    with True show ?thesis by(auto)
  next
    case False
    with call exp = aMvs; 𝒟 exp A  𝒟 (inline_call e' exp) A ‹calls (exp # exps) = aMvs ‹𝒟s (exp # exps) A
    have "𝒟 (inline_call e' exp) A" by auto
    moreover from False ‹calls (exp # exps) = aMvs have "𝒜 exp  𝒜 (inline_call e' exp)"
      by(auto intro: A_inline_call)
    hence "A  𝒜 exp  A  𝒜 (inline_call e' exp)" by(rule sqUn_lem2)
    with ‹𝒟s (exp # exps) A have "𝒟s exps (A  𝒜 (inline_call e' exp))"
      by(auto intro: Ds_mono')
    ultimately show ?thesis using False by(auto)
  qed
qed(fastforce split: if_split_asm elim: D_mono' intro: sqUn_lem2 sqUn_lem A_inline_call)+

lemma bisim_B: "bisim Vs e E xs E (length Vs)"
  and bisims_Bs: "bisims Vs es Es xs  ℬs Es (length Vs)"
apply(induct rule: bisim_bisims.inducts)
apply(auto intro: ℬ ℬs)
done

lemma bisim_expr_locks_eq: "bisim Vs e e' xs  expr_locks e = expr_locks e'"
  and bisims_expr_lockss_eq: "bisims Vs es es' xs  expr_lockss es = expr_lockss es'"
by(induct rule: bisim_bisims.inducts)(auto intro!: ext)

lemma bisim_list_expr_lockss_eq: "bisim_list es exs'  expr_lockss es = expr_lockss (map fst exs')"
apply(induct rule: bisim_list.induct)
apply(auto dest: bisim_expr_locks_eq)
done

context J1_heap_base begin

lemma [simp]:
  fixes e :: "('a, 'b, 'addr) exp" and es :: "('a, 'b, 'addr) exp list"
  shows τmove1_compP: "τmove1 (compP f P) h e = τmove1 P h e"
  and τmoves1_compP: "τmoves1 (compP f P) h es = τmoves1 P h es"
by(induct e and es rule: τmove1.induct τmoves1.induct) auto

lemma τMove1_compP [simp]: "τMove1 (compP f P) = τMove1 P"
by(intro ext) auto

lemma red1_preserves_unmod:
  " uf,P,t ⊢1 e, s -ta e', s'; unmod e i   (lcl s') ! i = (lcl s) ! i"
  
  and reds1_preserves_unmod:
  " uf,P,t ⊢1 es, s [-ta→] es', s'; unmods es i   (lcl s') ! i = (lcl s) ! i"
apply(induct rule: red1_reds1.inducts)
apply(auto split: if_split_asm)
done

lemma red1_unmod_preserved:
  " uf,P,t ⊢1 e, s -ta e', s'; unmod e i   unmod e' i"
  and reds1_unmods_preserved:
  " uf,P,t ⊢1 es, s [-ta→] es', s'; unmods es i   unmods es' i"
by(induct rule: red1_reds1.inducts)(auto split: if_split_asm)

lemma τred1t_unmod_preserved:
  " τred1gt uf P t h (e, xs) (e', xs'); unmod e i   unmod e' i"
by(induct rule: tranclp_induct2)(auto intro: red1_unmod_preserved)

lemma τred1r_unmod_preserved:
  " τred1gr uf P t h (e, xs) (e', xs'); unmod e i   unmod e' i"
by(induct rule: rtranclp_induct2)(auto intro: red1_unmod_preserved)

lemma τred1t_preserves_unmod: 
  "τred1gt uf P t h (e, xs) (e', xs'); unmod e i; i < length xs 
   xs' ! i = xs ! i"
apply(induct rule: tranclp_induct2)
 apply(auto dest: red1_preserves_unmod)
apply(drule red1_preserves_unmod)
apply(erule (1) τred1t_unmod_preserved)
apply(drule τred1t_preserves_len)
apply auto
done

lemma τred1'r_preserves_unmod: 
  "τred1gr uf P t h (e, xs) (e', xs'); unmod e i; i < length xs 
   xs' ! i = xs ! i"
apply(induct rule: converse_rtranclp_induct2)
 apply(auto dest: red1_preserves_unmod red1_unmod_preserved red1_preserves_len)
apply(frule (1) red1_unmod_preserved)
apply(frule red1_preserves_len)
apply(frule (1) red1_preserves_unmod)
apply auto
done

end

context J_heap_base begin

lemma [simp]:
  fixes e :: "('a, 'b, 'addr) exp" and es :: "('a, 'b, 'addr) exp list"
  shows τmove0_compP: "τmove0 (compP f P) h e = τmove0 P h e"
  and τmoves0_compP: "τmoves0 (compP f P) h es = τmoves0 P h es"
by(induct e and es rule: τmove0.induct τmoves0.induct) auto

lemma τMove0_compP [simp]: "τMove0 (compP f P) = τMove0 P"
by(intro ext) auto

end

end

Theory Correctness1Threaded

(*  Title:      JinjaThreads/Compiler/Correctness1Threaded.thy
    Author:     Andreas Lochbihler
*)

section ‹Unlocking a sync block never fails›

theory Correctness1Threaded imports 
  J0J1Bisim
  "../Framework/FWInitFinLift"
begin

definition lock_oks1 :: 
  "('addr,'thread_id) locks 
   ('addr,'thread_id,(('a,'b,'addr) exp × 'c) × (('a,'b,'addr) exp × 'c) list) thread_info  bool" 
where
  "ln. lock_oks1 ls ts  t. (case (ts t) of None     (l. has_locks (ls $ l) t = 0)
                            | ((ex, exs), ln)  (l. has_locks (ls $ l) t + ln $ l = expr_lockss (map fst (ex # exs)) l))"

primrec el_loc_ok :: "'addr expr1  'addr locals1  bool"
  and els_loc_ok :: "'addr expr1 list  'addr locals1  bool"
where
  "el_loc_ok (new C) xs  True"
| "el_loc_ok (newA Te) xs  el_loc_ok e xs"
| "el_loc_ok (Cast T e) xs  el_loc_ok e xs"
| "el_loc_ok (e instanceof T) xs  el_loc_ok e xs"
| "el_loc_ok (e«bop»e') xs  el_loc_ok e xs  el_loc_ok e' xs"
| "el_loc_ok (Var V) xs  True"
| "el_loc_ok (Val v) xs  True"
| "el_loc_ok (V := e) xs  el_loc_ok e xs"
| "el_loc_ok (ai) xs  el_loc_ok a xs  el_loc_ok i xs"
| "el_loc_ok (ai := e) xs  el_loc_ok a xs  el_loc_ok i xs  el_loc_ok e xs"
| "el_loc_ok (a∙length) xs  el_loc_ok a xs"
| "el_loc_ok (eF{D}) xs  el_loc_ok e xs"
| "el_loc_ok (eF{D} := e') xs  el_loc_ok e xs  el_loc_ok e' xs"
| "el_loc_ok (e∙compareAndSwap(DF, e', e'')) xs  el_loc_ok e xs  el_loc_ok e' xs  el_loc_ok e'' xs"
| "el_loc_ok (eM(ps)) xs  el_loc_ok e xs  els_loc_ok ps xs"
| "el_loc_ok {V:T=vo; e} xs  (case vo of None  el_loc_ok e xs | v  el_loc_ok e (xs[V := v]))"
| "el_loc_ok (syncV(e) e') xs  el_loc_ok e xs  el_loc_ok e' xs  unmod e' V"
| "el_loc_ok (insyncV(a) e) xs  xs ! V = Addr a  el_loc_ok e xs  unmod e V"
| "el_loc_ok (e;;e') xs  el_loc_ok e xs  el_loc_ok e' xs"
| "el_loc_ok (if (b) e else e') xs  el_loc_ok b xs  el_loc_ok e xs  el_loc_ok e' xs"
| "el_loc_ok (while (b) c) xs  el_loc_ok b xs  el_loc_ok c xs"
| "el_loc_ok (throw e) xs  el_loc_ok e xs"
| "el_loc_ok (try e catch(C V) e') xs  el_loc_ok e xs  el_loc_ok e' xs"

| "els_loc_ok [] xs  True"
| "els_loc_ok (e # es) xs  el_loc_ok e xs  els_loc_ok es xs"

lemma el_loc_okI: " ¬ contains_insync e; syncvars e;e n   el_loc_ok e xs"
  and els_loc_okI: " ¬ contains_insyncs es; syncvarss es; ℬs es n   els_loc_ok es xs"
by(induct e and es arbitrary: xs n and xs n rule: el_loc_ok.induct els_loc_ok.induct)(auto intro: fv_B_unmod)

lemma el_loc_ok_compE1: " ¬ contains_insync e; fv e  set Vs   el_loc_ok (compE1 Vs e) xs"
  and els_loc_ok_compEs1: " ¬ contains_insyncs es; fvs es  set Vs   els_loc_ok (compEs1 Vs es) xs"
by(auto intro: el_loc_okI els_loc_okI syncvars_compE1 syncvarss_compEs1 ℬ ℬs simp del: compEs1_conv_map)

lemma shows el_loc_ok_not_contains_insync_local_change:
  " ¬ contains_insync e; el_loc_ok e xs   el_loc_ok e xs'"
  and els_loc_ok_not_contains_insyncs_local_change:
  " ¬ contains_insyncs es; els_loc_ok es xs   els_loc_ok es xs'"
by(induct e and es arbitrary: xs xs' and xs xs' rule: el_loc_ok.induct els_loc_ok.induct)(fastforce)+

lemma el_loc_ok_update: "e n; V < n   el_loc_ok e (xs[V := v]) = el_loc_ok e xs"
  and els_loc_ok_update: " ℬs es n; V < n   els_loc_ok es (xs[V := v]) = els_loc_ok es xs"
apply(induct e and es arbitrary: n xs and n xs rule: el_loc_ok.induct els_loc_ok.induct) 
apply(auto simp add: list_update_swap)
done

lemma els_loc_ok_map_Val [simp]:
  "els_loc_ok (map Val vs) xs"
by(induct vs) auto

lemma els_loc_ok_map_Val_append [simp]:
  "els_loc_ok (map Val vs @ es) xs = els_loc_ok es xs"
by(induct vs) auto

lemma el_loc_ok_extRet2J [simp]:
  "el_loc_ok e xs  el_loc_ok (extRet2J e va) xs"
by(cases va) auto

definition el_loc_ok1 :: "((nat, nat, 'addr) exp × 'addr locals1) × ((nat, nat, 'addr) exp × 'addr locals1) list  bool"
  where "el_loc_ok1 = (λ((e, xs), exs). el_loc_ok e xs  sync_ok e  ((e,xs)set exs. el_loc_ok e xs  sync_ok e))"

lemma el_loc_ok1_simps:
  "el_loc_ok1 ((e, xs), exs) = (el_loc_ok e xs  sync_ok e  ((e,xs)set exs. el_loc_ok e xs  sync_ok e))"
by(simp add: el_loc_ok1_def)

lemma el_loc_ok_blocks1 [simp]:
   "el_loc_ok (blocks1 n Ts body) xs = el_loc_ok body xs"
by(induct n Ts body rule: blocks1.induct) auto

lemma sync_oks_blocks1 [simp]: "sync_ok (blocks1 n Ts e) = sync_ok e"
by(induct n Ts e rule: blocks1.induct) auto

lemma assumes fin: "final e'"
  shows el_loc_ok_inline_call: "el_loc_ok e xs  el_loc_ok (inline_call e' e) xs"
  and els_loc_ok_inline_calls: "els_loc_ok es xs  els_loc_ok (inline_calls e' es) xs"
apply(induct e and es arbitrary: xs and xs rule: el_loc_ok.induct els_loc_ok.induct)
apply(insert fin)
apply(auto simp add: unmod_inline_call)
done

lemma assumes "sync_ok e'"
  shows sync_ok_inline_call: "sync_ok e  sync_ok (inline_call e' e)"
  and sync_oks_inline_calls: "sync_oks es  sync_oks (inline_calls e' es)"
apply(induct e and es rule: sync_ok.induct sync_oks.induct)
apply(insert ‹sync_ok e')
apply auto
done

lemma bisim_sync_ok:
  "bisim Vs e e' xs  sync_ok e"
  "bisim Vs e e' xs  sync_ok e'"

  and bisims_sync_oks:
  "bisims Vs es es' xs  sync_oks es"
  "bisims Vs es es' xs  sync_oks es'"
apply(induct rule: bisim_bisims.inducts)
apply(auto intro: not_contains_insync_sync_ok not_contains_insyncs_sync_oks simp del: compEs1_conv_map)
done  

lemma assumes "final e'"
  shows expr_locks_inline_call_final:
  "expr_locks (inline_call e' e) = expr_locks e"
  and expr_lockss_inline_calls_final:
  "expr_lockss (inline_calls e' es) = expr_lockss es"
apply(induct e and es rule: expr_locks.induct expr_lockss.induct)
apply(insert ‹final e')
apply(auto simp add: is_vals_conv intro: ext)
done

lemma lock_oks1I:
  " t l. ts t = None  has_locks (ls $ l) t = 0;
     t e x exs ln l. ts t = (((e, x), exs), ln)  has_locks (ls $ l) t + ln $ l= expr_locks e l + expr_lockss (map fst exs) l 
   lock_oks1 ls ts"
apply(fastforce simp add: lock_oks1_def)
done

lemma lock_oks1E:
  " lock_oks1 ls ts;
     t. ts t = None  (l. has_locks (ls $ l) t = 0)  Q;
     t e x exs ln. ts t = (((e, x), exs), ln)  (l. has_locks (ls $ l) t + ln $ l = expr_locks e l + expr_lockss (map fst exs) l)  Q 
   Q"
by(fastforce simp add: lock_oks1_def)

lemma lock_oks1D1:
  " lock_oks1 ls ts; ts t = None   l. has_locks (ls $ l) t = 0"
apply(simp add: lock_oks1_def)
apply(erule_tac x="t" in allE)
apply(auto)
done

lemma lock_oks1D2:
  "ln.  lock_oks1 ls ts; ts t = (((e, x), exs), ln)  
   l. has_locks (ls $ l) t + ln $ l = expr_locks e l + expr_lockss (map fst exs) l"
apply(fastforce simp add: lock_oks1_def)
done

lemma lock_oks1_thr_updI:
  "ln.  lock_oks1 ls ts; ts t = (((e, xs), exs), ln);
     l. expr_locks e l + expr_lockss (map fst exs) l = expr_locks e' l + expr_lockss (map fst exs') l 
   lock_oks1 ls (ts(t  (((e', xs'), exs'), ln)))"
by(rule lock_oks1I)(auto split: if_split_asm dest: lock_oks1D2 lock_oks1D1)


definition mbisim_Red1'_Red1 ::
  "(('addr,'thread_id,('addr expr1 × 'addr locals1) × ('addr expr1 × 'addr locals1) list,'heap,'addr) state, 
    ('addr,'thread_id,('addr expr1 × 'addr locals1) × ('addr expr1 × 'addr locals1) list,'heap,'addr) state) bisim"
where
  "mbisim_Red1'_Red1 s1 s2 = 
  (s1 = s2  lock_oks1 (locks s1) (thr s1)  ts_ok (λt exexs h. el_loc_ok1 exexs) (thr s1) (shr s1))"

lemma sync_ok_blocks:
  " length vs = length pns; length Ts = length pns
   sync_ok (blocks pns Ts vs body) = sync_ok body"
by(induct pns Ts vs body rule: blocks.induct) auto

context J1_heap_base begin

lemma red1_True_into_red1_False:
  " True,P,t ⊢1 e, s -ta e', s'; el_loc_ok e (lcl s)  
   False,P,t ⊢1 e, s -ta e', s'  (l. ta = UnlockFaill  expr_locks e l > 0)"
  and reds1_True_into_reds1_False:
  " True,P,t ⊢1 es, s [-ta→] es', s'; els_loc_ok es (lcl s) 
   False,P,t ⊢1 es, s [-ta→] es', s'  (l. ta = UnlockFaill  expr_lockss es l > 0)"
apply(induct rule: red1_reds1.inducts)
apply(auto intro: red1_reds1.intros split: if_split_asm)
done

lemma Red1_True_into_Red1_False:
  assumes "True,P,t ⊢1 ex/exs,shr s -ta ex'/exs',m'"
  and "el_loc_ok1 (ex, exs)"
  shows "False,P,t ⊢1 ex/exs,shr s -ta ex'/exs',m'  
         (l. ta = UnlockFaill  expr_lockss (fst ex # map fst exs) l > 0)"
using assms
by(cases)(auto dest: Red1.intros red1_True_into_red1_False simp add: el_loc_ok1_def ta_upd_simps)

lemma shows red1_preserves_el_loc_ok:
  " uf,P,t ⊢1 e, s -ta e', s'; sync_ok e; el_loc_ok e (lcl s)   el_loc_ok e' (lcl s')"

  and reds1_preserves_els_loc_ok:
  " uf,P,t ⊢1 es, s [-ta→] es', s'; sync_oks es; els_loc_ok es (lcl s)   els_loc_ok es' (lcl s')"
proof(induct rule: red1_reds1.inducts)
  case (Synchronized1Red2 e s ta e' s' V a)
  from ‹el_loc_ok (insyncV (a) e) (lcl s)
  have "el_loc_ok e (lcl s)" "unmod e V" "lcl s ! V = Addr a" by auto
  from ‹sync_ok (insyncV (a) e) have "sync_ok e" by simp
  hence "el_loc_ok e' (lcl s')"
    using ‹el_loc_ok e (lcl s)
    by(rule Synchronized1Red2)
  moreover from uf,P,t ⊢1 e,s -ta e',s' ‹unmod e V have "unmod e' V"
    by(rule red1_unmod_preserved)
  moreover from red1_preserves_unmod[OF uf,P,t ⊢1 e,s -ta e',s' ‹unmod e V] ‹lcl s ! V = Addr a
  have "lcl s' ! V = Addr a" by simp
  ultimately show ?case by auto
qed(auto elim: el_loc_ok_not_contains_insync_local_change els_loc_ok_not_contains_insyncs_local_change)

lemma red1_preserves_sync_ok: " uf,P,t ⊢1 e, s -ta e', s'; sync_ok e   sync_ok e'"
  and reds1_preserves_sync_oks: " uf,P,t ⊢1 es, s [-ta→] es', s'; sync_oks es   sync_oks es'"
by(induct rule: red1_reds1.inducts)(auto elim: not_contains_insync_sync_ok)

lemma Red1_preserves_el_loc_ok1:
  assumes wf: "wf_J1_prog P"
  shows " uf,P,t ⊢1 ex/exs,m -ta ex'/exs',m'; el_loc_ok1 (ex, exs)    el_loc_ok1 (ex', exs')"
apply(erule Red1.cases)
  apply(auto simp add: el_loc_ok1_def dest: red1_preserves_el_loc_ok red1_preserves_sync_ok intro: el_loc_ok_inline_call sync_ok_inline_call)
 apply(fastforce dest!: sees_wf_mdecl[OF wf] simp add: wf_mdecl_def intro!: el_loc_okI dest: WT1_not_contains_insync intro: not_contains_insync_sync_ok)+
done

lemma assumes wf: "wf_J1_prog P"
  shows red1_el_loc_ok1_new_thread:
  " uf,P,t ⊢1 e, s -ta e', s'; NewThread t' (C, M, a) h  set tat 
   el_loc_ok1 (({0:Class (fst (method P C M))=None; the (snd (snd (snd (method P C M))))}, xs), [])"

  and reds1_el_loc_ok1_new_thread:
  " uf,P,t ⊢1 es, s [-ta→] es', s'; NewThread t' (C, M, a) h  set tat 
   el_loc_ok1 (({0:Class (fst (method P C M))=None; the (snd (snd (snd (method P C M))))}, xs), [])"
proof(induct rule: red1_reds1.inducts)
  case Red1CallExternal thus ?case
    apply(auto dest!: red_external_new_thread_sees[OF wf] simp add: el_loc_ok1_simps)
    apply(auto dest!: sees_wf_mdecl[OF wf] WT1_not_contains_insync simp add: wf_mdecl_def intro!: el_loc_okI not_contains_insync_sync_ok)
    done
qed auto

lemma Red1_el_loc_ok1_new_thread:
  assumes wf: "wf_J1_prog P"
  shows " uf,P,t ⊢1 ex/exs,m -ta ex'/exs',m'; NewThread t' exexs m'  set tat 
          el_loc_ok1 exexs"
by(erule Red1.cases)(fastforce elim: red1_el_loc_ok1_new_thread[OF wf] simp add: ta_upd_simps)+

lemma Red1_el_loc_ok: 
  assumes wf: "wf_J1_prog P"
  shows "lifting_wf final_expr1 (mred1g uf P) (λt exexs h. el_loc_ok1 exexs)"
by(unfold_locales)(auto elim: Red1_preserves_el_loc_ok1[OF wf] Red1_el_loc_ok1_new_thread[OF wf])

lemma mred1_eq_mred1':
  assumes lok: "lock_oks1 (locks s) (thr s)"
  and elo: "ts_ok (λt exexs h. el_loc_ok1 exexs) (thr s) (shr s)"
  and tst: "thr s t = (exexs, no_wait_locks)"
  and aoe: "Red1_mthr.actions_ok s t ta"
  shows "mred1 P t (exexs, shr s) ta = mred1' P t (exexs, shr s) ta"
proof(intro ext iffI)
  fix xm'
  assume "mred1 P t (exexs, shr s) ta xm'"
  moreover obtain ex exs where exexs [simp]: "exexs = (ex, exs)" by(cases exexs)
  moreover obtain ex' exs' m' where xm' [simp]: "xm' = ((ex', exs'), m')" by(cases xm') auto
  ultimately have red: "True,P,t ⊢1 ex/exs,shr s -ta ex'/exs',m'" by simp
  from elo tst have "el_loc_ok1 (ex, exs)" by(auto dest: ts_okD)
  from Red1_True_into_Red1_False[OF red this]
  have "False,P,t ⊢1 ex/exs,shr s -ta ex'/exs',m'"
  proof
    assume "l. ta = UnlockFaill  0 < expr_lockss (fst ex # map fst exs) l"
    then obtain l where ta: "ta = UnlockFaill" 
      and el: "expr_lockss (fst ex # map fst exs) l > 0" by blast
    from aoe have "lock_actions_ok (locks s $ l) t (tal $ l)"
      by(auto simp add: lock_ok_las_def)
    with ta have "has_locks (locks s $ l) t = 0" by simp
    with lok tst have "expr_lockss (map fst (ex # exs)) l = 0"
      by(cases ex)(auto 4 6 simp add: lock_oks1_def)
    with el have False by simp
    thus ?thesis ..
  qed
  thus "mred1' P t (exexs, shr s) ta xm'" by simp
next
  fix xm'
  assume "mred1' P t (exexs, shr s) ta xm'"
  thus "mred1 P t (exexs, shr s) ta xm'"
    by(cases xm')(auto simp add: split_beta intro: Red1_False_into_Red1_True)
qed

lemma Red1_mthr_eq_Red1_mthr':
  assumes lok: "lock_oks1 (locks s) (thr s)"
  and elo: "ts_ok (λt exexs h. el_loc_ok1 exexs) (thr s) (shr s)"
  shows "Red1_mthr.redT True P s = Red1_mthr.redT False P s"
proof(intro ext)
  fix tta s'
  show "Red1_mthr.redT True P s tta s' = Red1_mthr.redT False P s tta s'" (is "?lhs = ?rhs")
  proof
    assume "?lhs" thus ?rhs
    proof cases
      case (redT_normal t x ta x' m')
      from ‹mred1 P t (x, shr s) ta (x', m') have "mred1' P t (x, shr s) ta (x', m')"
        unfolding mred1_eq_mred1'[OF lok elo ‹thr s t = (x, no_wait_locks) ‹Red1_mthr.actions_ok s t ta] .
      thus ?thesis using redT_normal(3-) unfolding tta = (t, ta) ..
    next
      case (redT_acquire t x ln n)
      from this(2-) show ?thesis unfolding redT_acquire(1) ..
    qed
  next
    assume ?rhs thus ?lhs
    proof(cases)
      case (redT_normal t x ta x' m')
      from ‹mred1' P t (x, shr s) ta (x', m') have "mred1 P t (x, shr s) ta (x', m')"
        unfolding mred1_eq_mred1'[OF lok elo ‹thr s t = (x, no_wait_locks) ‹Red1_mthr.actions_ok s t ta] .
      thus ?thesis using redT_normal(3-) unfolding tta = (t, ta) ..
    next
      case (redT_acquire t x ln n)
      from this(2-) show ?thesis unfolding redT_acquire(1) ..
    qed
  qed
qed

lemma assumes wf: "wf_J1_prog P"
  shows expr_locks_new_thread1:
  " uf,P,t ⊢1 e,s -TA e',s'; NewThread t' (ex, exs) h  set (map (convert_new_thread_action (extNTA2J1 P)) TAt) 
   expr_lockss (map fst (ex # exs)) = (λad. 0)"
  and expr_lockss_new_thread1:
  " uf,P,t ⊢1 es,s [-TA→] es',s'; NewThread t' (ex, exs) h  set (map (convert_new_thread_action (extNTA2J1 P)) TAt) 
   expr_lockss (map fst (ex # exs)) = (λad. 0)"
proof(induct rule: red1_reds1.inducts)
  case (Red1CallExternal s a T M vs ta va h' e' s')
  then obtain C fs ad where subThread: "P  C * Thread" and ext: "extNTA2J1 P (C, run, ad) = (ex, exs)"
    by(fastforce dest: red_external_new_thread_sub_thread)
  from sub_Thread_sees_run[OF wf subThread] obtain D body
    where sees: "P  C sees run: []Void = body in D" by auto
  from sees_wf_mdecl[OF wf this] obtain T where "P,[Class D] ⊢1 body :: T"
    by(auto simp add: wf_mdecl_def)
  hence "¬ contains_insync body" by(rule WT1_not_contains_insync)
  hence "expr_locks body = (λad. 0)" by(auto simp add: contains_insync_conv fun_eq_iff)
  with sees ext show ?case by(auto)
qed auto

lemma assumes wf: "wf_J1_prog P"
  shows red1_update_expr_locks:
  " False,P,t ⊢1 e, s -ta e', s'; sync_ok e; el_loc_ok e (lcl s) 
   upd_expr_locks (int o expr_locks e) tal = int o expr_locks e'"

  and reds1_update_expr_lockss:
  " False,P,t ⊢1 es, s [-ta→] es', s'; sync_oks es; els_loc_ok es (lcl s) 
   upd_expr_locks (int o expr_lockss es) tal = int o expr_lockss es'"
proof -
  have " False,P,t ⊢1 e, s -ta e', s'; sync_ok e; el_loc_ok e (lcl s)  
        upd_expr_locks (λad. 0) tal = (λad. (int o expr_locks e') ad - (int o expr_locks e) ad)"
    and " False,P,t ⊢1 es, s [-ta→] es', s'; sync_oks es; els_loc_ok es (lcl s) 
        upd_expr_locks (λad. 0) tal = (λad. (int o expr_lockss es') ad - (int o expr_lockss es) ad)"
  proof(induct rule: red1_reds1.inducts)
    case Red1CallExternal thus ?case
      by(auto simp add: fun_eq_iff contains_insync_conv contains_insyncs_conv finfun_upd_apply elim!: red_external.cases)
  qed(fastforce simp add: fun_eq_iff contains_insync_conv contains_insyncs_conv finfun_upd_apply)+
  hence " False,P,t ⊢1 e, s -ta e', s'; sync_ok e; el_loc_ok e (lcl s) 
         upd_expr_locks (λad. 0 + (int  expr_locks e) ad) tal = int  expr_locks e'"
    and " False,P,t ⊢1 es, s [-ta→] es', s'; sync_oks es; els_loc_ok es (lcl s) 
         upd_expr_locks (λad. 0 + (int  expr_lockss es) ad) tal = int  expr_lockss es'"
    by(fastforce simp only: upd_expr_locks_add)+
  thus " False,P,t ⊢1 e, s -ta e', s'; sync_ok e; el_loc_ok e (lcl s) 
         upd_expr_locks (int o expr_locks e) tal = int o expr_locks e'"
    and " False,P,t ⊢1 es, s [-ta→] es', s'; sync_oks es; els_loc_ok es (lcl s) 
         upd_expr_locks (int o expr_lockss es) tal = int o expr_lockss es'"
    by(auto simp add: o_def)
qed

lemma Red1'_preserves_lock_oks:
  assumes wf: "wf_J1_prog P"
  and Red: "Red1_mthr.redT False P s1 ta1 s1'"
  and loks: "lock_oks1 (locks s1) (thr s1)"
  and sync: "ts_ok (λt exexs h. el_loc_ok1 exexs) (thr s1) (shr s1)"
  shows "lock_oks1 (locks s1') (thr s1')"
using Red
proof(cases rule: Red1_mthr.redT.cases)
  case (redT_normal t x ta x' m')
  note [simp] = ta1 = (t, ta)
  obtain ex exs where x: "x = (ex, exs)" by (cases x)
  obtain ex' exs' where x': "x' = (ex', exs')" by (cases x')
  note thrst = ‹thr s1 t = (x, no_wait_locks)
  note aoe = ‹Red1_mthr.actions_ok s1 t ta
  from ‹mred1' P t (x, shr s1) ta (x', m')
  have red: "False,P,t ⊢1 ex/exs,shr s1 -ta ex'/exs',m'"
    unfolding x x' by simp_all
  note s1' = ‹redT_upd s1 t ta x' m' s1'
  moreover from red 
  have "lock_oks1 (locks s1') (thr s1')"
  proof cases
    case (red1Red e x TA e' x')
    note [simp] = ex = (e, x) ta = extTA2J1 P TA ex' = (e', x') exs' = exs
      and red = ‹False,P,t ⊢1 e,(shr s1, x) -TA e',(m', x')
    { fix t'
      assume None: "(redT_updTs (thr s1) (map (convert_new_thread_action (extNTA2J1 P)) TAt)(t  (((e', x'), exs), redT_updLns (locks s1) t (snd (the (thr s1 t))) TAl))) t' = None"
      { fix l
        from aoe have "lock_actions_ok (locks s1 $ l) t (tal $ l)" by(auto simp add: lock_ok_las_def)
        with None have "has_locks ((redT_updLs (locks s1) t tal) $ l) t' = has_locks (locks s1 $ l) t'"
          by(auto split: if_split_asm)
        also from loks None have "has_locks (locks s1 $ l) t' = 0" unfolding lock_oks1_def
          by(force split: if_split_asm dest!: redT_updTs_None)
        finally have "has_locks (upd_locks (locks s1 $ l) t (TAl $ l)) t' = 0" by simp }
      hence "l. has_locks (upd_locks (locks s1 $ l) t (TAl $ l)) t' = 0" .. }
    moreover {
      fix t' eX eXS LN
      assume Some: "(redT_updTs (thr s1) (map (convert_new_thread_action (extNTA2J1 P)) TAt)(t  (((e', x'), exs), redT_updLns (locks s1) t (snd (the (thr s1 t))) TAl))) t' = ((eX, eXS), LN)"
      { fix l
        from aoe have lao: "lock_actions_ok (locks s1 $ l) t (tal $ l)" by(auto simp add: lock_ok_las_def)
        have "has_locks ((redT_updLs (locks s1) t tal) $ l) t' + LN $ l = expr_lockss (map fst (eX # eXS)) l"
        proof(cases "t = t'")
          case True
          from loks thrst x
          have "has_locks (locks s1 $ l) t = expr_locks e l + expr_lockss (map fst exs) l"
            by(force simp add: lock_oks1_def)
          hence "lock_expr_locks_ok (locks s1 $ l) t 0 (int (expr_locks e l + expr_lockss (map fst exs) l))"
            by(simp add: lock_expr_locks_ok_def)
          with lao have "lock_expr_locks_ok (upd_locks (locks s1 $ l) t (tal $ l)) t (upd_threadRs 0 (locks s1 $ l) t (tal $ l))
 (upd_expr_lock_actions (int (expr_locks e l + expr_lockss (map fst exs) l)) (tal $ l))"
            by(rule upd_locks_upd_expr_lock_preserve_lock_expr_locks_ok)
          moreover from sync thrst x have "sync_ok e" "el_loc_ok e x"
            unfolding el_loc_ok1_def by(auto dest: ts_okD)
          with red1_update_expr_locks[OF wf red]
          have "upd_expr_locks (int  expr_locks e) TAl = int  expr_locks e'" by(simp)
          hence "upd_expr_lock_actions (int (expr_locks e l)) (TAl $ l) = int (expr_locks e' l)"
            by(simp add: upd_expr_locks_def fun_eq_iff)
          ultimately show ?thesis using lao Some thrst x True
            by(auto simp add: lock_expr_locks_ok_def upd_expr_locks_def)
        next
          case False
          from aoe have tok: "thread_oks (thr s1) tat" by auto
          show ?thesis
          proof(cases "thr s1 t' = None")
            case True
            with Some tok False obtain m 
              where nt: "NewThread t' (eX, eXS) m  set (map (convert_new_thread_action (extNTA2J1 P)) TAt)"
              and [simp]: "LN = no_wait_locks" by(auto dest: redT_updTs_new_thread)
            note expr_locks_new_thread1[OF wf red nt]
            moreover from loks True have "has_locks (locks s1 $ l) t' = 0"
              by(force simp add: lock_oks1_def)
            ultimately show ?thesis using lao False by simp
          next
            case False
            with Some t  t' tok 
            have "thr s1 t' = ((eX, eXS), LN)" by(fastforce dest: redT_updTs_Some[OF _ tok])
            with loks tok lao t  t' show ?thesis by(cases eX)(auto simp add: lock_oks1_def)
          qed
        qed }
      hence "l. has_locks ((redT_updLs (locks s1) t tal) $ l) t' + LN $ l = expr_lockss (map fst (eX # eXS)) l" .. }
    ultimately show ?thesis using s1' unfolding lock_oks1_def x' by(clarsimp simp del: fun_upd_apply)
  next
    case (red1Call e a M vs U Ts T body D x)
    from wf P  class_type_of U sees M: TsT = body in D
    obtain T' where "P,Class D # Ts ⊢1 body :: T'"
      by(auto simp add: wf_mdecl_def dest!: sees_wf_mdecl)
    hence "expr_locks (blocks1 0 (Class D#Ts) body) = (λl. 0)"
      by(auto simp add: expr_locks_blocks1 contains_insync_conv fun_eq_iff dest!: WT1_not_contains_insync)
    thus ?thesis using red1Call thrst loks s1'
      unfolding lock_oks1_def x' x
      by auto force+
  next
    case (red1Return e' x' e x)
    thus ?thesis using thrst loks s1'
      unfolding lock_oks1_def x' x
      apply(auto simp add: redT_updWs_def elim!: rtrancl3p_cases)
       apply(erule_tac x=t in allE)
       apply(erule conjE)
       apply(erule disjE)
        apply(force simp add: expr_locks_inline_call_final ac_simps)
       apply(fastforce simp add: expr_locks_inline_call_final)
      apply hypsubst_thin
      apply(erule_tac x=ta in allE)
      apply fastforce
      done
  qed
  moreover from sync ‹mred1' P t (x, shr s1) ta (x', m') thrst aoe s1'
  have "ts_ok (λt exexs h. el_loc_ok1 exexs) (thr s1') (shr s1')"
    by(auto intro: lifting_wf.redT_updTs_preserves[OF Red1_el_loc_ok[OF wf]])
  ultimately show ?thesis by simp
next
  case (redT_acquire t x n ln)
  thus ?thesis using loks unfolding lock_oks1_def
    apply auto
     apply force
    apply(case_tac "ln $ l::nat")
     apply simp
     apply(erule allE)
     apply(erule conjE)
     apply(erule allE)+
     apply(erule (1) impE)
     apply(erule_tac x=l in allE)
     apply fastforce
    apply(erule may_acquire_allE)
    apply(erule allE)
    apply(erule_tac x=l in allE)
    apply(erule impE)
     apply simp
    apply(simp only: has_locks_acquire_locks_conv)
    apply(erule conjE)
    apply(erule allE)+
    apply(erule (1) impE)
    apply(erule_tac x=l in allE)
    apply simp
    done
qed

lemma Red1'_Red1_bisimulation:
  assumes wf: "wf_J1_prog P"
  shows "bisimulation (Red1_mthr.redT False P) (Red1_mthr.redT True P) mbisim_Red1'_Red1 (=)"
proof
  fix s1 s2 tl1 s1'
  assume "mbisim_Red1'_Red1 s1 s2" and "Red1_mthr.redT False P s1 tl1 s1'"
  thus "s2' tl2. Red1_mthr.redT True P s2 tl2 s2'  mbisim_Red1'_Red1 s1' s2'  tl1 = tl2"
    by(cases tl1)(auto simp add: mbisim_Red1'_Red1_def Red1_mthr_eq_Red1_mthr' simp del: split_paired_Ex elim: Red1'_preserves_lock_oks[OF wf] lifting_wf.redT_preserves[OF Red1_el_loc_ok, OF wf])
next
  fix s1 s2 tl2 s2'
  assume "mbisim_Red1'_Red1 s1 s2" "Red1_mthr.redT True P s2 tl2 s2'"
  thus "s1' tl1. Red1_mthr.redT False P s1 tl1 s1'  mbisim_Red1'_Red1 s1' s2'  tl1 = tl2"
    by(cases tl2)(auto simp add: mbisim_Red1'_Red1_def Red1_mthr_eq_Red1_mthr' simp del: split_paired_Ex elim: Red1'_preserves_lock_oks[OF wf] lifting_wf.redT_preserves[OF Red1_el_loc_ok, OF wf])
qed

lemma Red1'_Red1_bisimulation_final:
  "wf_J1_prog P 
   bisimulation_final (Red1_mthr.redT False P) (Red1_mthr.redT True P) 
       mbisim_Red1'_Red1 (=) Red1_mthr.mfinal Red1_mthr.mfinal"
apply(intro_locales)
 apply(erule Red1'_Red1_bisimulation)
apply(unfold_locales)
apply(auto simp add: mbisim_Red1'_Red1_def)
done

lemma bisim_J1_J1_start:
  assumes wf: "wf_J1_prog P"
  and wf_start: "wf_start_state P C M vs"
  shows "mbisim_Red1'_Red1 (J1_start_state P C M vs) (J1_start_state P C M vs)"
proof -
  from wf_start obtain Ts T body D 
    where sees: "P  C sees M:TsT=body in D"
    and conf: "P,start_heap  vs [:≤] Ts"
    by cases
  let ?e = "blocks1 0 (Class C#Ts) body"
  let ?xs = "Null # vs @ replicate (max_vars body) undefined_value"

  from sees_wf_mdecl[OF wf sees] obtain T'
    where B: "ℬ body (Suc (length Ts))"
    and wt: "P,Class D # Ts ⊢1 body :: T'"
    and da: "𝒟 body {..length Ts}"
    and sv: "syncvars body"
    by(auto simp add: wf_mdecl_def)

  from wt have "expr_locks ?e = (λ_. 0)" by(auto intro: WT1_expr_locks)
  thus ?thesis using da sees sv B
    unfolding start_state_def
    by(fastforce simp add: mbisim_Red1'_Red1_def lock_oks1_def el_loc_ok1_def contains_insync_conv intro!: ts_okI expr_locks_sync_ok split: if_split_asm intro: el_loc_okI)
qed

lemma Red1'_Red1_bisim_into_weak:
  assumes wf: "wf_J1_prog P"
  shows "bisimulation_into_delay (Red1_mthr.redT False P) (Red1_mthr.redT True P) mbisim_Red1'_Red1 (=) (Red1_mthr.mτmove P) (Red1_mthr.mτmove P)"
proof -
  interpret b: bisimulation "Red1_mthr.redT False P" "Red1_mthr.redT True P" "mbisim_Red1'_Red1" "(=)"
    by(rule Red1'_Red1_bisimulation[OF wf])
  show ?thesis by(unfold_locales)(simp add: mbisim_Red1'_Red1_def)
qed

end

sublocale J1_heap_base < Red1_mthr:
  if_τmultithreaded_wf
    final_expr1
    "mred1g uf P"
    convert_RA
    "τMOVE1 P"
  for uf P
by(unfold_locales)

context J1_heap_base begin

abbreviation if_lock_oks1 ::
  "('addr,'thread_id) locks 
   ('addr,'thread_id,(status × (('a,'b,'addr) exp × 'c) × (('a,'b,'addr) exp × 'c) list)) thread_info
   bool" 
where
  "if_lock_oks1 ls ts  lock_oks1 ls (init_fin_descend_thr ts)"

definition if_mbisim_Red1'_Red1 ::
  "(('addr,'thread_id,status × (('addr expr1 × 'addr locals1) × ('addr expr1 × 'addr locals1) list),'heap,'addr) state, 
    ('addr,'thread_id,status × (('addr expr1 × 'addr locals1) × ('addr expr1 × 'addr locals1) list),'heap,'addr) state) bisim"
where
  "if_mbisim_Red1'_Red1 s1 s2 
  s1 = s2  if_lock_oks1 (locks s1) (thr s1)  ts_ok (init_fin_lift (λt exexs h. el_loc_ok1 exexs)) (thr s1) (shr s1)"

lemma if_mbisim_Red1'_Red1_imp_mbisim_Red1'_Red1:
  "if_mbisim_Red1'_Red1 s1 s2  mbisim_Red1'_Red1 (init_fin_descend_state s1) (init_fin_descend_state s2)"
by(auto simp add: mbisim_Red1'_Red1_def if_mbisim_Red1'_Red1_def ts_ok_init_fin_descend_state)

lemma if_Red1_mthr_imp_if_Red1_mthr':
  assumes lok: "if_lock_oks1 (locks s) (thr s)"
  and elo: "ts_ok (init_fin_lift (λt exexs h. el_loc_ok1 exexs)) (thr s) (shr s)"
  and Red: "Red1_mthr.if.redT uf P s tta s'"
  shows "Red1_mthr.if.redT (¬ uf) P s tta s'"
using Red
proof(cases)
  case (redT_acquire t x ln n)
  from this(2-) show ?thesis unfolding redT_acquire(1) ..
next
  case (redT_normal t x ta x' m')
  note aok = ‹Red1_mthr.if.actions_ok s t ta
    and tst = ‹thr s t = (x, no_wait_locks)
  from ‹Red1_mthr.init_fin uf P t (x, shr s) ta (x', m')
  have "Red1_mthr.init_fin (¬ uf) P t (x, shr s) ta (x', m')"
  proof(cases)
    case InitialThreadAction show ?thesis unfolding InitialThreadAction ..
  next
    case (ThreadFinishAction exexs)
    from ‹final_expr1 exexs show ?thesis unfolding ThreadFinishAction ..
  next
    case (NormalAction exexs ta' exexs')
    let ?s = "init_fin_descend_state s"

    from lok have "lock_oks1 (locks ?s) (thr ?s)" by(simp)
    moreover from elo have elo: "ts_ok (λt exexs h. el_loc_ok1 exexs) (thr ?s) (shr ?s)"
      by(simp add: ts_ok_init_fin_descend_state)
    moreover from tst x = (Running, exexs)
    have "thr ?s t = (exexs, no_wait_locks)" by simp
    moreover from aok have "Red1_mthr.actions_ok ?s t ta'"
      using ta = convert_TA_initial (convert_obs_initial ta') by auto
    ultimately have "mred1 P t (exexs, shr ?s) ta' = mred1' P t (exexs, shr ?s) ta'"
      by(rule mred1_eq_mred1')
    with ‹mred1g uf P t (exexs, shr s) ta' (exexs', m')
    have "mred1g (¬ uf) P t (exexs, shr s) ta' (exexs', m')"
      by(cases uf) simp_all
    thus ?thesis unfolding NormalAction(1-3) by(rule Red1_mthr.init_fin.NormalAction)
  qed
  thus ?thesis using tst aok ‹redT_upd s t ta x' m' s' unfolding tta = (t, ta) ..
qed

lemma if_Red1_mthr_eq_if_Red1_mthr':
  assumes lok: "if_lock_oks1 (locks s) (thr s)"
  and elo: "ts_ok (init_fin_lift (λt exexs h. el_loc_ok1 exexs)) (thr s) (shr s)"
  shows "Red1_mthr.if.redT True P s = Red1_mthr.if.redT False P s"
using if_Red1_mthr_imp_if_Red1_mthr'[OF assms, of True P, simplified]
  if_Red1_mthr_imp_if_Red1_mthr'[OF assms, of False P, simplified]
by(blast del: equalityI)

lemma if_Red1_el_loc_ok: 
  assumes wf: "wf_J1_prog P"
  shows "lifting_wf Red1_mthr.init_fin_final (Red1_mthr.init_fin uf P) (init_fin_lift (λt exexs h. el_loc_ok1 exexs))"
by(rule lifting_wf.lifting_wf_init_fin_lift)(rule Red1_el_loc_ok[OF wf])

lemma if_Red1'_preserves_if_lock_oks:
  assumes wf: "wf_J1_prog P"
  and Red: "Red1_mthr.if.redT False P s1 ta1 s1'"
  and loks: "if_lock_oks1 (locks s1) (thr s1)"
  and sync: "ts_ok (init_fin_lift (λt exexs h. el_loc_ok1 exexs)) (thr s1) (shr s1)"
  shows "if_lock_oks1 (locks s1') (thr s1')"
proof -
  let ?s1 = "init_fin_descend_state s1"
  let ?s1' = "init_fin_descend_state s1'"
  from loks have loks': "lock_oks1 (locks ?s1) (thr ?s1)" by simp
  from sync have sync': "ts_ok (λt exexs h. el_loc_ok1 exexs) (thr ?s1) (shr ?s1)"
    by(simp add: ts_ok_init_fin_descend_state)
  from Red show ?thesis
  proof(cases)
    case (redT_acquire t x n ln)
    hence "Red1_mthr.redT False P ?s1 (t, K$ [], [], [], [], [], convert_RA ln) ?s1'"
      by(cases x)(auto intro!: Red1_mthr.redT.redT_acquire simp add: init_fin_descend_thr_def)
    with wf have "lock_oks1 (locks ?s1') (thr ?s1')" using loks' sync' by(rule Red1'_preserves_lock_oks)
    thus ?thesis by simp
  next
    case (redT_normal t sx ta sx' m')
    note tst = ‹thr s1 t = (sx, no_wait_locks)
    from ‹Red1_mthr.init_fin False P t (sx, shr s1) ta (sx', m')
    show ?thesis
    proof(cases)
      case (InitialThreadAction x) thus ?thesis using redT_normal loks
        by(cases x)(auto 4 3 simp add: init_fin_descend_thr_def redT_updLns_def expand_finfun_eq fun_eq_iff intro: lock_oks1_thr_updI)
    next
      case (ThreadFinishAction x) thus ?thesis using redT_normal loks
        by(cases x)(auto 4 3 simp add: init_fin_descend_thr_def redT_updLns_def expand_finfun_eq fun_eq_iff intro: lock_oks1_thr_updI)
    next
      case (NormalAction x ta' x')
      note ta = ta = convert_TA_initial (convert_obs_initial ta')
      from ‹mred1' P t (x, shr s1) ta' (x', m')
      have "mred1' P t (x, shr ?s1) ta' (x', m')" by simp
      moreover have tst': "thr ?s1 t = (x, no_wait_locks)" 
        using tst sx = (Running, x) by simp
      moreover have "Red1_mthr.actions_ok ?s1 t ta'"
        using ta ‹Red1_mthr.if.actions_ok s1 t ta by simp
      moreover from ‹redT_upd s1 t ta sx' m' s1' tst tst' ta sx' = (Running, x')
      have "redT_upd ?s1 t ta' x' m' ?s1'" by auto
      ultimately have "Red1_mthr.redT False P ?s1 (t, ta') ?s1'" ..
      with wf have "lock_oks1 (locks ?s1') (thr ?s1')" using loks' sync' by(rule Red1'_preserves_lock_oks)
      thus ?thesis by simp
    qed
  qed
qed

lemma Red1'_Red1_if_bisimulation:
  assumes wf: "wf_J1_prog P"
  shows "bisimulation (Red1_mthr.if.redT False P) (Red1_mthr.if.redT True P) if_mbisim_Red1'_Red1 (=)"
proof
  fix s1 s2 tl1 s1'
  assume "if_mbisim_Red1'_Red1 s1 s2" and "Red1_mthr.if.redT False P s1 tl1 s1'"
  thus "s2' tl2. Red1_mthr.if.redT True P s2 tl2 s2'  if_mbisim_Red1'_Red1 s1' s2'  tl1 = tl2"
    by(cases tl1)(auto simp add: if_mbisim_Red1'_Red1_def if_Red1_mthr_eq_if_Red1_mthr' simp del: split_paired_Ex elim: if_Red1'_preserves_if_lock_oks[OF wf] lifting_wf.redT_preserves[OF if_Red1_el_loc_ok, OF wf])
next
  fix s1 s2 tl2 s2'
  assume "if_mbisim_Red1'_Red1 s1 s2" "Red1_mthr.if.redT True P s2 tl2 s2'"
  thus "s1' tl1. Red1_mthr.if.redT False P s1 tl1 s1'  if_mbisim_Red1'_Red1 s1' s2'  tl1 = tl2"
    by(cases tl2)(auto simp add: if_mbisim_Red1'_Red1_def if_Red1_mthr_eq_if_Red1_mthr' simp del: split_paired_Ex elim: if_Red1'_preserves_if_lock_oks[OF wf] lifting_wf.redT_preserves[OF if_Red1_el_loc_ok, OF wf])
qed

lemma if_bisim_J1_J1_start:
  assumes wf: "wf_J1_prog P"
  and wf_start: "wf_start_state P C M vs"
  shows "if_mbisim_Red1'_Red1 (init_fin_lift_state status (J1_start_state P C M vs)) (init_fin_lift_state status (J1_start_state P C M vs))"
proof -
  from assms have "mbisim_Red1'_Red1 (J1_start_state P C M vs) (J1_start_state P C M vs)" by(rule bisim_J1_J1_start)
  thus ?thesis
    by(simp add: if_mbisim_Red1'_Red1_def mbisim_Red1'_Red1_def)(simp add: init_fin_lift_state_conv_simps init_fin_descend_thr_def thr_init_fin_list_state' o_def map_option.compositionality map_option.identity split_beta)
qed

lemma if_Red1'_Red1_bisim_into_weak:
  assumes wf: "wf_J1_prog P"
  shows "bisimulation_into_delay (Red1_mthr.if.redT False P) (Red1_mthr.if.redT True P) if_mbisim_Red1'_Red1 (=) (Red1_mthr.if.mτmove P) (Red1_mthr.if.mτmove P)"
proof -
  interpret b: bisimulation "Red1_mthr.if.redT False P" "Red1_mthr.if.redT True P" "if_mbisim_Red1'_Red1" "(=)"
    by(rule Red1'_Red1_if_bisimulation[OF wf])
  show ?thesis by(unfold_locales)(simp add: if_mbisim_Red1'_Red1_def)
qed

lemma if_Red1'_Red1_bisimulation_final:
  "wf_J1_prog P 
   bisimulation_final (Red1_mthr.if.redT False P) (Red1_mthr.if.redT True P) 
       if_mbisim_Red1'_Red1 (=) Red1_mthr.if.mfinal Red1_mthr.if.mfinal"
apply(intro_locales)
 apply(erule Red1'_Red1_if_bisimulation)
apply(unfold_locales)
apply(auto simp add: if_mbisim_Red1'_Red1_def)
done

end

end

Theory Correctness1

(*  Title:      JinjaThreads/Compiler/Correctness1.thy
    Author:     Andreas Lochbihler, Tobias Nipkow

    reminiscent of the Jinja theory Compiler/Correctness1
*)

section ‹Semantic Correctness of Stage 1›

theory Correctness1 imports
  J0J1Bisim
  "../J/DefAssPreservation"
begin

lemma finals_map_Val [simp]: "finals (map Val vs)"
by(simp add: finals_iff)

context J_heap_base begin

lemma τred0r_preserves_defass:
  assumes wf: "wf_J_prog P"
  shows " τred0r extTA P t h (e, xs) (e', xs'); 𝒟 e dom xs   𝒟 e' dom xs'"
by(induct rule: rtranclp_induct2)(auto dest: red_preserves_defass[OF wf])

lemma τred0t_preserves_defass:
  assumes wf: "wf_J_prog P"
  shows " τred0t extTA P t h (e, xs) (e', xs'); 𝒟 e dom xs   𝒟 e' dom xs'"
by(rule τred0r_preserves_defass[OF wf])(rule tranclp_into_rtranclp)

end

lemma LAss_lem:
  "x  set xs; size xs  size ys 
   m1 m m2(xs[↦]ys)  m1(xy) m m2(xs[↦]ys[index xs x := y])"
apply(simp add:map_le_def)
apply(simp add:fun_upds_apply index_less_aux eq_sym_conv)
done

lemma Block_lem:
fixes l :: "'a  'b"
assumes 0: "l m [Vs [↦] ls]"
    and 1: "l' m [Vs [↦] ls', Vv]"
    and hidden: "V  set Vs  ls ! index Vs V = ls' ! index Vs V"
    and size: "size ls = size ls'"    "size Vs < size ls'"
shows "l'(V := l V) m [Vs [↦] ls']"
proof -
  have "l'(V := l V) m [Vs [↦] ls', Vv](V := l V)"
    using 1 by(rule map_le_upd)
  also have " = [Vs [↦] ls'](V := l V)" by simp
  also have " m [Vs [↦] ls']"
  proof (cases "l V")
    case None thus ?thesis by simp
  next
    case (Some w)
    hence "[Vs [↦] ls] V = Some w"
      using 0 by(force simp add: map_le_def split:if_splits)
    hence VinVs: "V  set Vs" and w: "w = ls ! index Vs V"
      using size by(auto simp add:fun_upds_apply split:if_splits)
    hence "w = ls' ! index Vs V" using hidden[OF VinVs] by simp
    hence "[Vs [↦] ls'](V := l V) = [Vs [↦] ls']"
      using Some size VinVs by(simp add:index_less_aux map_upds_upd_conv_index)
    thus ?thesis by simp
  qed
  finally show ?thesis .
qed

subsection ‹Correctness proof›

locale J0_J1_heap_base =
  J?: J_heap_base +
  J1?: J1_heap_base + 
  constrains addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
begin

lemma ta_bisim01_extTA2J0_extTA2J1:
  assumes wf: "wf_J_prog P"
  and nt: "n T C M a h.  n < length tat; tat ! n = NewThread T (C, M, a) h 
            typeof_addr h a = Class_type C  (T meth D. P  C sees M:[]T =meth in D)"
  shows "ta_bisim01 (extTA2J0 P ta) (extTA2J1 (compP1 P) ta)"
apply(simp add: ta_bisim_def ta_upd_simps)
apply(auto intro!: list_all2_all_nthI)
apply(case_tac "tat ! n")
  apply(auto simp add: bisim_red0_Red1_def)
apply(drule (1) nt)
apply(clarify)
apply(erule bisim_list_extTA2J0_extTA2J1[OF wf, simplified])
done

lemma red_external_ta_bisim01: 
  " wf_J_prog P; P,t  aM(vs), h -ta→ext va, h'   ta_bisim01 (extTA2J0 P ta) (extTA2J1 (compP1 P) ta)"
apply(rule ta_bisim01_extTA2J0_extTA2J1, assumption)
apply(drule (1) red_external_new_thread_sees, auto simp add: in_set_conv_nth)
apply(drule red_ext_new_thread_heap, auto simp add: in_set_conv_nth)
done

lemmas τred1t_expr =
  NewArray_τred1t_xt Cast_τred1t_xt InstanceOf_τred1t_xt BinOp_τred1t_xt1 BinOp_τred1t_xt2 LAss_τred1t
  AAcc_τred1t_xt1 AAcc_τred1t_xt2 AAss_τred1t_xt1 AAss_τred1t_xt2 AAss_τred1t_xt3
  ALength_τred1t_xt FAcc_τred1t_xt FAss_τred1t_xt1 FAss_τred1t_xt2 
  CAS_τred1t_xt1 CAS_τred1t_xt2 CAS_τred1t_xt3 Call_τred1t_obj
  Call_τred1t_param Block_None_τred1t_xt Block_τred1t_Some Sync_τred1t_xt InSync_τred1t_xt
  Seq_τred1t_xt Cond_τred1t_xt Throw_τred1t_xt Try_τred1t_xt

lemmas τred1r_expr =
  NewArray_τred1r_xt Cast_τred1r_xt InstanceOf_τred1r_xt BinOp_τred1r_xt1 BinOp_τred1r_xt2 LAss_τred1r
  AAcc_τred1r_xt1 AAcc_τred1r_xt2 AAss_τred1r_xt1 AAss_τred1r_xt2 AAss_τred1r_xt3
  ALength_τred1r_xt FAcc_τred1r_xt FAss_τred1r_xt1 FAss_τred1r_xt2
  CAS_τred1r_xt1 CAS_τred1r_xt2 CAS_τred1r_xt3 Call_τred1r_obj
  Call_τred1r_param Block_None_τred1r_xt Block_τred1r_Some Sync_τred1r_xt InSync_τred1r_xt
  Seq_τred1r_xt Cond_τred1r_xt Throw_τred1r_xt Try_τred1r_xt

definition sim_move01 :: 
  "'addr J1_prog  'thread_id  ('addr, 'thread_id, 'heap) J0_thread_action  'addr expr  'addr expr1  'heap
   'addr locals1  ('addr, 'thread_id, 'heap) external_thread_action  'addr expr1  'heap  'addr locals1  bool"
where
  "sim_move01 P t ta0 e0 e h xs ta e' h' xs'  ¬ final e0 
  (if τmove0 P h e0 then h' = h  ta0 = ε  ta = ε  τred1't P t h (e, xs) (e', xs')
   else ta_bisim01 ta0 (extTA2J1 P ta) 
     (if call e0 = None  call1 e = None
      then (e'' xs''. τred1'r P t h (e, xs) (e'', xs'')  False,P,t ⊢1 e'', (h, xs'') -ta e', (h', xs') 
                       ¬ τmove1 P h e'')
      else False,P,t ⊢1 e, (h, xs) -ta e', (h', xs')  ¬ τmove1 P h e))"

definition sim_moves01 :: 
  "'addr J1_prog  'thread_id  ('addr, 'thread_id, 'heap) J0_thread_action  'addr expr list  'addr expr1 list  'heap
   'addr locals1  ('addr, 'thread_id, 'heap) external_thread_action  'addr expr1 list  'heap  'addr locals1  bool"
where
  "sim_moves01 P t ta0 es0 es h xs ta es' h' xs'  ¬ finals es0 
  (if τmoves0 P h es0 then h' = h  ta0 = ε  ta = ε  τreds1't P t h (es, xs) (es', xs')
   else ta_bisim01 ta0 (extTA2J1 P ta) 
     (if calls es0 = None  calls1 es = None
      then (es'' xs''. τreds1'r P t h (es, xs) (es'', xs'')  False,P,t ⊢1 es'', (h, xs'') [-ta→] es', (h', xs')  
                        ¬ τmoves1 P h es'')
      else False,P,t ⊢1 es, (h, xs) [-ta→] es', (h', xs')  ¬ τmoves1 P h es))"

declare τred1t_expr [elim!] τred1r_expr[elim!]

lemma sim_move01_expr:
  assumes "sim_move01 P t ta0 e0 e h xs ta e' h' xs'"
  shows
  "sim_move01 P t ta0 (newA Te0) (newA Te) h xs ta (newA Te') h' xs'"
  "sim_move01 P t ta0 (Cast T e0) (Cast T e) h xs ta (Cast T e') h' xs'"
  "sim_move01 P t ta0 (e0 instanceof T) (e instanceof T) h xs ta (e' instanceof T) h' xs'"
  "sim_move01 P t ta0 (e0 «bop» e2) (e «bop» e2') h xs ta (e' «bop» e2') h' xs'"
  "sim_move01 P t ta0 (Val v «bop» e0) (Val v «bop» e) h xs ta (Val v «bop» e') h' xs'"
  "sim_move01 P t ta0 (V := e0) (V' := e) h xs ta (V' := e') h' xs'"
  "sim_move01 P t ta0 (e0e2) (ee2') h xs ta (e'e2') h' xs'"
  "sim_move01 P t ta0 (Val ve0) (Val ve) h xs ta (Val ve') h' xs'"
  "sim_move01 P t ta0 (e0e2 := e3) (ee2' := e3') h xs ta (e'e2' := e3') h' xs'"
  "sim_move01 P t ta0 (Val ve0 := e3) (Val ve := e3') h xs ta (Val ve' := e3') h' xs'"
  "sim_move01 P t ta0 (AAss (Val v) (Val v') e0) (AAss (Val v) (Val v') e) h xs ta (AAss (Val v) (Val v') e') h' xs'"
  "sim_move01 P t ta0 (e0∙length) (e∙length) h xs ta (e'∙length) h' xs'"
  "sim_move01 P t ta0 (e0F{D}) (eF'{D'}) h xs ta (e'F'{D'}) h' xs'"
  "sim_move01 P t ta0 (FAss e0 F D e2) (FAss e F' D' e2') h xs ta (FAss e' F' D' e2') h' xs'"
  "sim_move01 P t ta0 (FAss (Val v) F D e0) (FAss (Val v) F' D' e) h xs ta (FAss (Val v) F' D' e') h' xs'"
  "sim_move01 P t ta0 (CompareAndSwap e0 D F e2 e3) (CompareAndSwap e D F e2' e3') h xs ta (CompareAndSwap e' D F e2' e3') h' xs'"
  "sim_move01 P t ta0 (CompareAndSwap (Val v) D F e0 e3) (CompareAndSwap (Val v) D F e e3') h xs ta (CompareAndSwap (Val v) D F e' e3') h' xs'"
  "sim_move01 P t ta0 (CompareAndSwap (Val v) D F (Val v') e0) (CompareAndSwap (Val v) D F (Val v') e) h xs ta (CompareAndSwap (Val v) D F (Val v') e') h' xs'"
  "sim_move01 P t ta0 (e0M(es)) (eM(es')) h xs ta (e'M(es')) h' xs'"
  "sim_move01 P t ta0 ({V:T=vo; e0}) ({V':T=None; e}) h xs ta ({V':T=None; e'}) h' xs'"
  "sim_move01 P t ta0 (sync(e0) e2) (syncV'(e) e2') h xs ta (syncV'(e') e2') h' xs'"
  "sim_move01 P t ta0 (insync(a) e0) (insyncV'(a') e) h xs ta (insyncV'(a') e') h' xs'"
  "sim_move01 P t ta0 (e0;;e2) (e;;e2') h xs ta (e';;e2') h' xs'"
  "sim_move01 P t ta0 (if (e0) e2 else e3) (if (e) e2' else e3') h xs ta (if (e') e2' else e3') h' xs'"
  "sim_move01 P t ta0 (throw e0) (throw e) h xs ta (throw e') h' xs'"
  "sim_move01 P t ta0 (try e0 catch(C V) e2) (try e catch(C' V') e2') h xs ta (try e' catch(C' V') e2') h' xs'"
using assms
apply(simp_all add: sim_move01_def final_iff τred1r_Val τred1t_Val split: if_split_asm split del: if_split)
apply(fastforce simp add: final_iff τred1r_Val τred1t_Val split!: if_splits intro: red1_reds1.intros)+
done

lemma sim_moves01_expr:
  "sim_move01 P t ta0 e0 e h xs ta e' h' xs'  sim_moves01 P t ta0 (e0 # es2) (e # es2') h xs ta (e' # es2') h' xs'"
  "sim_moves01 P t ta0 es0 es h xs ta es' h' xs'  sim_moves01 P t ta0 (Val v # es0) (Val v # es) h xs ta (Val v # es') h' xs'"
apply(simp_all add: sim_move01_def sim_moves01_def final_iff finals_iff Cons_eq_append_conv τred1t_Val τred1r_Val split: if_split_asm split del: if_split)
apply(auto simp add: Cons_eq_append_conv τred1t_Val τred1r_Val split!: if_splits intro: List1Red1 List1Red2 τred1t_inj_τreds1t τred1r_inj_τreds1r τreds1t_cons_τreds1t τreds1r_cons_τreds1r)
apply(force elim!: τred1r_inj_τreds1r List1Red1)
apply(force elim!: τred1r_inj_τreds1r List1Red1)
apply(force elim!: τred1r_inj_τreds1r List1Red1)
apply(force elim!: τred1r_inj_τreds1r List1Red1)
apply(force elim!: τreds1r_cons_τreds1r intro!: List1Red2)
apply(force elim!: τreds1r_cons_τreds1r intro!: List1Red2)
done

lemma sim_move01_CallParams:
  "sim_moves01 P t ta0 es0 es h xs ta es' h' xs'
   sim_move01 P t ta0 (Val vM(es0)) (Val vM(es)) h xs ta (Val vM(es')) h' xs'"
apply(clarsimp simp add: sim_move01_def sim_moves01_def τreds1r_map_Val τreds1t_map_Val is_vals_conv split: if_split_asm split del: if_split)
  apply(fastforce simp add: sim_move01_def sim_moves01_def τreds1r_map_Val τreds1t_map_Val intro: Call_τred1r_param Call1Params)
 apply(rule conjI, fastforce)
 apply(split if_split)
 apply(rule conjI)
  apply(clarsimp simp add: finals_iff)
 apply(clarify)
 apply(split if_split)
 apply(rule conjI)
  apply(simp del: call.simps calls.simps call1.simps calls1.simps)
  apply(fastforce simp add: sim_move01_def sim_moves01_def τred1r_Val τred1t_Val τreds1r_map_Val_Throw intro: Call_τred1r_param Call1Params split: if_split_asm)
 apply(fastforce split: if_split_asm simp add: is_vals_conv τreds1r_map_Val τreds1r_map_Val_Throw)
apply(rule conjI, fastforce)
apply(fastforce simp add: sim_move01_def sim_moves01_def τred1r_Val τred1t_Val τreds1t_map_Val τreds1r_map_Val is_vals_conv intro: Call_τred1r_param Call1Params split: if_split_asm)
done

lemma sim_move01_reds:
  " (h', a)  allocate h (Class_type C); ta0 = NewHeapElem a (Class_type C); ta = NewHeapElem a (Class_type C) 
   sim_move01 P t ta0 (new C) (new C) h xs ta (addr a) h' xs"
  "allocate h (Class_type C) = {}  sim_move01 P t ε (new C) (new C) h xs ε (THROW OutOfMemory) h xs"
  " (h', a)  allocate h (Array_type T (nat (sint i))); 0 <=s i;
     ta0 = NewHeapElem a (Array_type T (nat (sint i))); ta = NewHeapElem a (Array_type T (nat (sint i))) 
   sim_move01 P t ta0 (newA TVal (Intg i)) (newA TVal (Intg i)) h xs ta (addr a) h' xs"
  "i <s 0  sim_move01 P t ε (newA TVal (Intg i)) (newA TVal (Intg i)) h xs ε (THROW NegativeArraySize) h xs"
  " allocate h (Array_type T (nat (sint i))) = {}; 0 <=s i 
   sim_move01 P t ε (newA TVal (Intg i)) (newA TVal (Intg i)) h xs ε (THROW OutOfMemory) h xs"
  " typeofh v = U; P  U  T 
   sim_move01 P t ε (Cast T (Val v)) (Cast T (Val v)) h xs ε (Val v) h xs"
  " typeofh v = U; ¬ P  U  T 
   sim_move01 P t ε (Cast T (Val v)) (Cast T (Val v)) h xs ε (THROW ClassCast) h xs"
  " typeofh v = U; b  v  Null  P  U  T 
   sim_move01 P t ε ((Val v) instanceof T) ((Val v) instanceof T) h xs ε (Val (Bool b)) h xs"
  "binop bop v1 v2 = Some (Inl v)  sim_move01 P t ε ((Val v1) «bop» (Val v2)) (Val v1 «bop» Val v2) h xs ε (Val v) h xs"
  "binop bop v1 v2 = Some (Inr a)  sim_move01 P t ε ((Val v1) «bop» (Val v2)) (Val v1 «bop» Val v2) h xs ε (Throw a) h xs"
  " xs!V = v; V < size xs   sim_move01 P t ε (Var V') (Var V) h xs ε (Val v) h xs"
  "V < length xs  sim_move01 P t ε (V' := Val v) (V := Val v) h xs ε unit h (xs[V := v])"
  "sim_move01 P t ε (nullVal v) (nullVal v) h xs ε (THROW NullPointer) h xs"
  " typeof_addr h a = Array_type T n; i <s 0  sint i  int n 
   sim_move01 P t ε (addr aVal (Intg i)) ((addr a)Val (Intg i)) h xs ε (THROW ArrayIndexOutOfBounds) h xs"
  " typeof_addr h a = Array_type T n; 0 <=s i; sint i < int n;
     heap_read h a (ACell (nat (sint i))) v;
     ta0 = ReadMem a (ACell (nat (sint i))) v; 
     ta = ReadMem a (ACell (nat (sint i))) v 
   sim_move01 P t ta0 (addr aVal (Intg i)) ((addr a)Val (Intg i)) h xs ta (Val v) h xs"
  "sim_move01 P t ε (nullVal v := Val v') (nullVal v := Val v') h xs ε (THROW NullPointer) h xs"
  " typeof_addr h a = Array_type T n; i <s 0  sint i  int n 
   sim_move01 P t ε (AAss (addr a) (Val (Intg i)) (Val v)) (AAss (addr a) (Val (Intg i)) (Val v)) h xs ε (THROW ArrayIndexOutOfBounds) h xs"
 " typeof_addr h a = Array_type T n; 0 <=s i; sint i < int n; typeofh v = U; ¬ (P  U  T) 
   sim_move01 P t ε (AAss (addr a) (Val (Intg i)) (Val v)) (AAss (addr a) (Val (Intg i)) (Val v)) h xs ε (THROW ArrayStore) h xs"
  " typeof_addr h a = Array_type T n; 0 <=s i; sint i < int n; typeofh v = Some U; P  U  T;
     heap_write h a (ACell (nat (sint i))) v h'; 
     ta0 = WriteMem a (ACell (nat (sint i))) v; ta = WriteMem a (ACell (nat (sint i))) v  
   sim_move01 P t ta0 (AAss (addr a) (Val (Intg i)) (Val v)) (AAss (addr a) (Val (Intg i)) (Val v)) h xs ta unit h' xs"
  "typeof_addr h a = Array_type T n  sim_move01 P t ε (addr a∙length) (addr a∙length) h xs ε (Val (Intg (word_of_int (int n)))) h xs"
  "sim_move01 P t ε (null∙length) (null∙length) h xs ε (THROW NullPointer) h xs"

  " heap_read h a (CField D F) v; ta0 = ReadMem a (CField D F) v; ta = ReadMem a (CField D F) v 
   sim_move01 P t ta0 (addr aF{D}) (addr aF{D}) h xs ta (Val v) h xs"
  "sim_move01 P t ε (nullF{D}) (nullF{D}) h xs ε (THROW NullPointer) h xs"
  " heap_write h a (CField D F) v h'; ta0 = WriteMem a (CField D F) v; ta = WriteMem a (CField D F) v 
   sim_move01 P t ta0 (addr aF{D} := Val v) (addr aF{D} := Val v) h xs ta unit h' xs"
  "sim_move01 P t ε (null∙compareAndSwap(DF, Val v, Val v')) (null∙compareAndSwap(DF, Val v, Val v')) h xs ε (THROW NullPointer) h xs"
  " heap_read h a (CField D F) v''; heap_write h a (CField D F) v' h'; v'' = v; 
     ta0 = ReadMem a (CField D F) v'', WriteMem a (CField D F) v'; ta = ReadMem a (CField D F) v'', WriteMem a (CField D F) v' 
   sim_move01 P t ta0 (addr a∙compareAndSwap(DF, Val v, Val v')) (addr a∙compareAndSwap(DF, Val v, Val v')) h xs ta true h' xs"
  " heap_read h a (CField D F) v''; v''  v; 
     ta0 = ReadMem a (CField D F) v''; ta = ReadMem a (CField D F) v'' 
   sim_move01 P t ta0 (addr a∙compareAndSwap(DF, Val v, Val v')) (addr a∙compareAndSwap(DF, Val v, Val v')) h xs ta false h xs"
  "sim_move01 P t ε (nullF{D} := Val v) (nullF{D} := Val v) h xs ε (THROW NullPointer) h xs"
  "sim_move01 P t ε ({V':T=vo; Val u}) ({V:T=None; Val u}) h xs ε (Val u) h xs"
  "V < length xs  sim_move01 P t ε (sync(null) e0) (syncV (null) e1) h xs ε (THROW NullPointer) h (xs[V := Null])"
  "sim_move01 P t ε (Val v;;e0) (Val v;; e1) h xs ε e1 h xs"
  "sim_move01 P t ε (if (true) e0 else e0') (if (true) e1 else e1') h xs ε e1 h xs"
  "sim_move01 P t ε (if (false) e0 else e0') (if (false) e1 else e1') h xs ε e1' h xs"
  "sim_move01 P t ε (throw null) (throw null) h xs ε (THROW NullPointer) h xs"
  "sim_move01 P t ε (try (Val v) catch(C V') e0) (try (Val v) catch(C V) e1) h xs ε (Val v) h xs"
  " typeof_addr h a = Class_type D; P  D * C; V < length xs 
   sim_move01 P t ε (try (Throw a) catch(C V') e0) (try (Throw a) catch(C V) e1) h xs ε ({V:Class C=None; e1}) h (xs[V := Addr a])"
  "sim_move01 P t ε (newA TThrow a) (newA TThrow a) h xs ε (Throw a) h xs"
  "sim_move01 P t ε (Cast T (Throw a)) (Cast T (Throw a)) h xs ε (Throw a) h xs"
  "sim_move01 P t ε ((Throw a) instanceof T) ((Throw a) instanceof T) h xs ε (Throw a) h xs"
  "sim_move01 P t ε ((Throw a) «bop» e0) ((Throw a) «bop» e1) h xs ε (Throw a) h xs"
  "sim_move01 P t ε (Val v «bop» (Throw a)) (Val v «bop» (Throw a)) h xs ε (Throw a) h xs"
  "sim_move01 P t ε (V' := Throw a) (V := Throw a) h xs ε (Throw a) h xs"
  "sim_move01 P t ε (Throw ae0) (Throw ae1) h xs ε (Throw a) h xs"
  "sim_move01 P t ε (Val vThrow a) (Val vThrow a) h xs ε (Throw a) h xs"
  "sim_move01 P t ε (Throw ae0 := e0') (Throw ae1 := e1') h xs ε (Throw a) h xs"
  "sim_move01 P t ε (Val vThrow a := e0) (Val vThrow a := e1) h xs ε (Throw a) h xs"
  "sim_move01 P t ε (Val vVal v' := Throw a) (Val vVal v' := Throw a) h xs ε (Throw a) h xs"
  "sim_move01 P t ε (Throw a∙length) (Throw a∙length) h xs ε (Throw a) h xs"
  "sim_move01 P t ε (Throw aF{D}) (Throw aF{D}) h xs ε (Throw a) h xs"
  "sim_move01 P t ε (Throw aF{D} := e0) (Throw aF{D} := e1) h xs ε (Throw a) h xs"
  "sim_move01 P t ε (Val vF{D} := Throw a) (Val vF{D} := Throw a) h xs ε (Throw a) h xs"
  "sim_move01 P t ε (Throw a∙compareAndSwap(DF, e2, e3)) (Throw a∙compareAndSwap(DF, e2', e3')) h xs ε (Throw a) h xs"
  "sim_move01 P t ε (Val v∙compareAndSwap(DF, Throw a, e3)) (Val v∙compareAndSwap(DF, Throw a, e3')) h xs ε (Throw a) h xs"
  "sim_move01 P t ε (Val v∙compareAndSwap(DF, Val v', Throw a)) (Val v∙compareAndSwap(DF, Val v', Throw a)) h xs ε (Throw a) h xs"
  "sim_move01 P t ε (Throw aM(es0)) (Throw aM(es1)) h xs ε (Throw a) h xs"
  "sim_move01 P t ε ({V':T=vo; Throw a}) ({V:T=None; Throw a}) h xs ε (Throw a) h xs"
  "sim_move01 P t ε (sync(Throw a) e0) (syncV(Throw a) e1) h xs ε (Throw a) h xs"
  "sim_move01 P t ε (Throw a;;e0) (Throw a;;e1) h xs ε (Throw a) h xs"
  "sim_move01 P t ε (if (Throw a) e0 else e0') (if (Throw a) e1 else e1') h xs ε (Throw a) h xs"
  "sim_move01 P t ε (throw (Throw a)) (throw (Throw a)) h xs ε (Throw a) h xs"
apply(simp_all add: sim_move01_def ta_bisim_def split: if_split_asm split del: if_split)
apply(fastforce intro: red1_reds1.intros)+
done

lemma sim_move01_ThrowParams:
  "sim_move01 P t ε (Val vM(map Val vs @ Throw a # es0)) (Val vM(map Val vs @ Throw a # es1)) h xs ε (Throw a) h xs"
apply(simp add: sim_move01_def split del: if_split)
apply(rule conjI, fastforce)
apply(split if_split)
apply(rule conjI)
 apply(fastforce intro: red1_reds1.intros)
apply(fastforce simp add: sim_move01_def intro: red1_reds1.intros)
done

lemma sim_move01_CallNull:
  "sim_move01 P t ε (nullM(map Val vs)) (nullM(map Val vs)) h xs ε (THROW NullPointer) h xs"
by(fastforce simp add: sim_move01_def map_eq_append_conv intro: red1_reds1.intros)

lemma sim_move01_SyncLocks:
  " V < length xs; ta0 = Locka, SyncLock a; ta = Locka, SyncLock a 
    sim_move01 P t ta0 (sync(addr a) e0) (syncV (addr a) e1) h xs ta (insyncV (a) e1) h (xs[V := Addr a])"
  " xs ! V = Addr a'; V < length xs; ta0 = Unlocka', SyncUnlock a'; ta = Unlocka', SyncUnlock a' 
   sim_move01 P t ta0 (insync(a') (Val v)) (insyncV (a) (Val v)) h xs ta (Val v) h xs"
  " xs ! V = Addr a'; V < length xs; ta0 = Unlocka', SyncUnlock a'; ta = Unlocka', SyncUnlock a' 
   sim_move01 P t ta0 (insync(a') (Throw a'')) (insyncV (a) (Throw a'')) h xs ta (Throw a'') h xs"
by(fastforce simp add: sim_move01_def ta_bisim_def expand_finfun_eq fun_eq_iff finfun_upd_apply ta_upd_simps  intro: red1_reds1.intros[simplified] split: if_split_asm)+

lemma sim_move01_TryFail:
  " typeof_addr h a = Class_type D; ¬ P  D * C 
   sim_move01 P t ε (try (Throw a) catch(C V') e0) (try (Throw a) catch(C V) e1) h xs ε (Throw a) h xs"
by(auto simp add: sim_move01_def intro!: Red1TryFail)

lemma sim_move01_BlockSome:
  " sim_move01 P t ta0 e0 e h (xs[V := v]) ta e' h' xs'; V < length xs 
   sim_move01 P t ta0 ({V':T=v; e0}) ({V:T=v; e}) h xs ta ({V:T=None; e'}) h' xs'"
  "V < length xs  sim_move01 P t ε ({V':T=v; Val u}) ({V:T=v; Val u}) h xs ε (Val u) h (xs[V := v])"
  "V < length xs  sim_move01 P t ε ({V':T=v; Throw a}) ({V:T=v; Throw a}) h xs ε (Throw a) h (xs[V := v])"
apply(auto simp add: sim_move01_def)
apply(split if_split_asm)
 apply(fastforce intro: intro: converse_rtranclp_into_rtranclp Block1Some Block1Red Block_τred1r_Some)
apply(fastforce intro: intro: converse_rtranclp_into_rtranclp Block1Some Block1Red Block_τred1r_Some)
apply(fastforce simp add: sim_move01_def intro!: τred1t_2step[OF Block1Some] τred1r_1step[OF Block1Some] Red1Block Block1Throw)+
done

lemmas sim_move01_intros =
  sim_move01_expr sim_move01_reds sim_move01_ThrowParams sim_move01_CallNull sim_move01_TryFail
  sim_move01_BlockSome sim_move01_CallParams

declare sim_move01_intros[intro]

lemma sim_move01_preserves_len: "sim_move01 P t ta0 e0 e h xs ta e' h' xs'  length xs' = length xs"
by(fastforce simp add: sim_move01_def split: if_split_asm dest: τred1r_preserves_len τred1t_preserves_len red1_preserves_len)

lemma sim_move01_preserves_unmod:
  " sim_move01 P t ta0 e0 e h xs ta e' h' xs'; unmod e i; i < length xs   xs' ! i = xs ! i"
apply(auto simp add: sim_move01_def split: if_split_asm dest: τred1t_preserves_unmod)
apply(frule (2) τred1'r_preserves_unmod)
apply(frule (1) τred1r_unmod_preserved)
apply(frule τred1r_preserves_len)
apply(auto dest: red1_preserves_unmod)
apply(frule (2) τred1'r_preserves_unmod)
apply(frule (1) τred1r_unmod_preserved)
apply(frule τred1r_preserves_len)
apply(auto dest: red1_preserves_unmod)
done

lemma assumes wf: "wf_J_prog P"
  shows red1_simulates_red_aux:
  " extTA2J0 P,P,t  e1, S -TA e1', S'; bisim vs e1 e2 XS; fv e1  set vs;
     lcl S m [vs [↦] XS]; length vs + max_vars e1  length XS;
     aMvs. call e1 = aMvs  synthesized_call P (hp S) aMvs 
   ta e2' XS'. sim_move01 (compP1 P) t TA e1 e2 (hp S) XS ta e2' (hp S') XS'  bisim vs e1' e2' XS'  lcl S' m [vs [↦] XS']"
  (is " _; _; _; _; _; ?synth e1 S   ?concl e1 e2 S XS e1' S' TA vs")

  and reds1_simulates_reds_aux:
  " extTA2J0 P,P,t  es1, S [-TA→] es1', S'; bisims vs es1 es2 XS; fvs es1  set vs;
    lcl S m [vs [↦] XS]; length vs + max_varss es1  length XS;
    aMvs. calls es1 = aMvs  synthesized_call P (hp S) aMvs 
   ta es2' xs'. sim_moves01 (compP1 P) t TA es1 es2 (hp S) XS ta es2' (hp S') xs'  bisims vs es1' es2' xs'  lcl S' m [vs [↦] xs']"
  (is " _; _; _; _; _; ?synths es1 S   ?concls es1 es2 S XS es1' S' TA vs")
proof(induct arbitrary: vs e2 XS and vs es2 XS rule: red_reds.inducts)
  case (BinOpRed1 e s ta e' s' bop e2 Vs E2 xs)
  note IH = vs e2 XS. bisim vs e e2 XS; fv e  set vs; lcl s m [vs [↦] XS]; length vs + max_vars e  length XS;
            ?synth e s   ?concl e e2 s XS e' s' ta vs
  from ‹extTA2J0 P,P,t  e,s -ta e',s' have "¬ is_val e" by auto
  with ‹bisim Vs (e «bop» e2) E2 xs obtain E
    where "E2 = E «bop» compE1 Vs e2" and "bisim Vs e E xs" and "¬ contains_insync e2" by auto
  with IH[of Vs E xs] ‹fv (e «bop» e2)  set Vs ‹lcl s m [Vs [↦] xs] ¬ is_val e
    ‹length Vs + max_vars (e «bop» e2)  length xs ?synth (e «bop» e2) s ‹extTA2J0 P,P,t  e,s -ta e',s'
  show ?case by(cases "is_val e'")(fastforce elim!: sim_move01_expr)+
next
  case (BinOpRed2 e s ta e' s' v bop Vs E2 xs)
  note IH = vs e2 XS. bisim vs e e2 XS; fv e  set vs; lcl s m [vs [↦] XS]; length vs + max_vars e  length XS;
            ?synth e s   ?concl e e2 s XS e' s' ta vs
  from ‹bisim Vs (Val v «bop» e) E2 xs obtain E
    where "E2 = Val v «bop» E" and "bisim Vs e E xs" by auto
  with IH[of Vs E xs] ‹fv (Val v «bop» e)  set Vs ‹lcl s m [Vs [↦] xs]
    ‹length Vs + max_vars (Val v «bop» e)  length xs ?synth (Val v «bop» e) s ‹extTA2J0 P,P,t  e,s -ta e',s'
  show ?case by(fastforce elim!: sim_move01_expr)
next
  case RedVar thus ?case
    by(fastforce simp add: index_less_aux map_le_def fun_upds_apply intro!: exI dest: bspec)
next
  case RedLAss thus ?case
    by(fastforce intro: index_less_aux LAss_lem intro!: exI simp del: fun_upd_apply)
next
  case (AAccRed1 a s ta a' s' i Vs E2 xs)
  note IH = vs e2 XS. bisim vs a e2 XS; fv a  set vs; lcl s m [vs [↦] XS]; length vs + max_vars a  length XS;
            ?synth a s   ?concl a e2 s XS a' s' ta vs
  from ‹extTA2J0 P,P,t  a,s -ta a',s' have "¬ is_val a" by auto
  with ‹bisim Vs (ai) E2 xs obtain E
    where "E2 = EcompE1 Vs i" and "bisim Vs a E xs" and "¬ contains_insync i" by auto
  with IH[of Vs E xs] ‹fv (ai)  set Vs ‹lcl s m [Vs [↦] xs] ¬ is_val a
    ‹length Vs + max_vars (ai)  length xs ?synth (ai) s ‹extTA2J0 P,P,t  a,s -ta a',s'
  show ?case by(cases "is_val a'")(fastforce elim!: sim_move01_expr)+
next
  case (AAccRed2 i s ta i' s' a Vs E2 xs)
  note IH = vs e2 XS. bisim vs i e2 XS; fv i  set vs; lcl s m [vs [↦] XS]; length vs + max_vars i  length XS;
            ?synth i s   ?concl i e2 s XS i' s' ta vs
  from ‹bisim Vs (Val ai) E2 xs obtain E
    where "E2 = Val aE" and "bisim Vs i E xs" by auto
  with IH[of Vs E xs] ‹fv (Val ai)  set Vs ‹lcl s m [Vs [↦] xs]
    ‹length Vs + max_vars (Val ai)  length xs ?synth (Val ai) s ‹extTA2J0 P,P,t  i,s -ta i',s'
  show ?case by(fastforce elim!: sim_move01_expr)
next
  case RedAAcc thus ?case by(auto simp del: split_paired_Ex)
next
  case (AAssRed1 a s ta a' s' i e Vs E2 xs)
  note IH = vs e2 XS. bisim vs a e2 XS; fv a  set vs; lcl s m [vs [↦] XS]; length vs + max_vars a  length XS;
            ?synth a s   ?concl a e2 s XS a' s' ta vs
  from ‹extTA2J0 P,P,t  a,s -ta a',s' have "¬ is_val a" by auto
  with ‹bisim Vs (ai:=e) E2 xs obtain E
    where E2: "E2 = EcompE1 Vs i:=compE1 Vs e" and "bisim Vs a E xs"
    and sync: "¬ contains_insync i" "¬ contains_insync e" by auto
  with IH[of Vs E xs] ‹fv (ai:=e)  set Vs ‹lcl s m [Vs [↦] xs] ¬ is_val a ‹extTA2J0 P,P,t  a,s -ta a',s'
    ‹length Vs + max_vars (ai:=e)  length xs ?synth (ai:=e) s
  obtain ta' e2' xs'
    where IH': "sim_move01 (compP1 P) t ta a E (hp s) xs ta' e2' (hp s') xs'"
    "bisim Vs a' e2' xs'" "lcl s' m [Vs [↦] xs']"
    by auto
  show ?case
  proof(cases "is_val a'")
    case True
    from ‹fv (ai:=e)  set Vs sync
    have "bisim Vs i (compE1 Vs i) xs'" "bisim Vs e (compE1 Vs e) xs'" by auto
    with IH' E2 True sync  ¬ is_val a ‹extTA2J0 P,P,t  a,s -ta a',s' show ?thesis
      by(cases "is_val i")(fastforce elim!: sim_move01_expr)+
  next
    case False with IH' E2 sync ¬ is_val a ‹extTA2J0 P,P,t  a,s -ta a',s'
    show ?thesis by(fastforce elim!: sim_move01_expr)
  qed
next
  case (AAssRed2 i s ta i' s' a e Vs E2 xs)
  note IH = vs e2 XS. bisim vs i e2 XS; fv i  set vs; lcl s m [vs [↦] XS]; length vs + max_vars i  length XS;
            ?synth i s   ?concl i e2 s XS i' s' ta vs
  from ‹extTA2J0 P,P,t  i,s -ta i',s' have "¬ is_val i" by auto
  with ‹bisim Vs (Val ai := e) E2 xs obtain E
    where "E2 = Val aE:=compE1 Vs e" and "bisim Vs i E xs" and "¬ contains_insync e" by auto
  with IH[of Vs E xs] ‹fv (Val ai:=e)  set Vs ‹lcl s m [Vs [↦] xs] ¬ is_val i ‹extTA2J0 P,P,t  i,s -ta i',s'
    ‹length Vs + max_vars (Val ai:=e)  length xs ?synth (Val ai:=e) s
  show ?case by(cases "is_val i'")(fastforce elim!: sim_move01_expr)+
next
  case (AAssRed3 e s ta e' s' a i Vs E2 xs)
  note IH = vs e2 XS. bisim vs e e2 XS; fv e  set vs; lcl s m [vs [↦] XS]; length vs + max_vars e  length XS;
            ?synth e s   ?concl e e2 s XS e' s' ta vs
  from ‹bisim Vs (Val aVal i := e) E2 xs obtain E
    where "E2 = Val aVal i:=E" and "bisim Vs e E xs" by auto
  with IH[of Vs E xs] ‹fv (Val aVal i:=e)  set Vs ‹lcl s m [Vs [↦] xs] ‹extTA2J0 P,P,t  e,s -ta e',s'
    ‹length Vs + max_vars (Val aVal i:=e)  length xs ?synth (Val aVal i:=e) s
  show ?case by(fastforce elim!: sim_move01_expr)
next
  case RedAAssStore thus ?case by(auto intro!: exI)
next
  case (FAssRed1 e s ta e' s' F D e2 Vs E2 xs)
  note IH = vs e2 XS. bisim vs e e2 XS; fv e  set vs; lcl s m [vs [↦] XS]; length vs + max_vars e  length XS;
            ?synth e s   ?concl e e2 s XS e' s' ta vs
  from ‹extTA2J0 P,P,t  e,s -ta e',s' have "¬ is_val e" by auto
  with ‹bisim Vs (eF{D} := e2) E2 xs obtain E
    where "E2 = EF{D} := compE1 Vs e2" and "bisim Vs e E xs" and "¬ contains_insync e2" by auto
  with IH[of Vs E xs] ‹fv (eF{D} := e2)  set Vs ‹lcl s m [Vs [↦] xs] ¬ is_val e ‹extTA2J0 P,P,t  e,s -ta e',s'
    ‹length Vs + max_vars (eF{D} := e2)  length xs ?synth (eF{D} := e2) s
  show ?case by(cases "is_val e'")(fastforce elim!: sim_move01_expr)+
next
  case (FAssRed2 e s ta e' s' v F D Vs E2 xs)
  note IH = vs e2 XS. bisim vs e e2 XS; fv e  set vs; lcl s m [vs [↦] XS]; length vs + max_vars e  length XS;
            ?synth e s   ?concl e e2 s XS e' s' ta vs
  from ‹bisim Vs (Val vF{D} := e) E2 xs obtain E
    where "E2 = Val vF{D} := E" and "bisim Vs e E xs" by auto
  with IH[of Vs E xs] ‹fv (Val vF{D} := e)  set Vs ‹lcl s m [Vs [↦] xs] ‹extTA2J0 P,P,t  e,s -ta e',s'
    ‹length Vs + max_vars (Val vF{D} := e)  length xs ?synth (Val vF{D} := e) s
  show ?case by(fastforce elim!: sim_move01_expr)
next
  case (CASRed1 e s ta e' s' D F e2 e3 Vs E2 xs)
  note IH = vs e2 XS. bisim vs e e2 XS; fv e  set vs; lcl s m [vs [↦] XS]; length vs + max_vars e  length XS;
            ?synth e s   ?concl e e2 s XS e' s' ta vs
  from ‹extTA2J0 P,P,t  e,s -ta e',s' have "¬ is_val e" by auto
  with ‹bisim Vs _ E2 xs obtain E
    where E2: "E2 = E∙compareAndSwap(DF, compE1 Vs e2, compE1 Vs e3)" and "bisim Vs e E xs"
    and sync: "¬ contains_insync e2" "¬ contains_insync e3" by(auto)
  with IH[of Vs E xs] ‹fv _  set Vs ‹lcl s m [Vs [↦] xs] ¬ is_val e ‹extTA2J0 P,P,t  e,s -ta e',s'
    ‹length Vs + max_vars _  length xs ?synth _ s
  obtain ta' e2' xs'
    where IH': "sim_move01 (compP1 P) t ta e E (hp s) xs ta' e2' (hp s') xs'"
    "bisim Vs e' e2' xs'" "lcl s' m [Vs [↦] xs']"
    by auto
  show ?case
  proof(cases "is_val e'")
    case True
    from ‹fv _  set Vs sync
    have "bisim Vs e2 (compE1 Vs e2) xs'" "bisim Vs e3 (compE1 Vs e3) xs'" by auto
    with IH' E2 True sync  ¬ is_val e ‹extTA2J0 P,P,t  e,s -ta e',s' show ?thesis
      by(cases "is_val e2")(fastforce elim!: sim_move01_expr)+
  next
    case False with IH' E2 sync ¬ is_val e ‹extTA2J0 P,P,t  e,s -ta e',s'
    show ?thesis by(fastforce elim!: sim_move01_expr)
  qed
next
  case (CASRed2 e s ta e' s' v D F e3 Vs E2 xs)
  note IH = vs e2 XS. bisim vs e e2 XS; fv e  set vs; lcl s m [vs [↦] XS]; length vs + max_vars e  length XS;
            ?synth e s   ?concl e e2 s XS e' s' ta vs
  from ‹extTA2J0 P,P,t  e,s -ta e',s' have "¬ is_val e" by auto
  with ‹bisim Vs _ E2 xs obtain E
    where "E2 = Val v∙compareAndSwap(DF, E, compE1 Vs e3)" and "bisim Vs e E xs" and "¬ contains_insync e3" by(auto)
  with IH[of Vs E xs] ‹fv _  set Vs ‹lcl s m [Vs [↦] xs] ¬ is_val e ‹extTA2J0 P,P,t  e,s -ta e',s'
    ‹length Vs + max_vars _  length xs ?synth _ s
  show ?case by(cases "is_val e'")(fastforce elim!: sim_move01_expr)+
next
  case (CASRed3 e s ta e' s' v D F v' Vs E2 xs)
  note IH = vs e2 XS. bisim vs e e2 XS; fv e  set vs; lcl s m [vs [↦] XS]; length vs + max_vars e  length XS;
            ?synth e s   ?concl e e2 s XS e' s' ta vs
  from ‹bisim Vs _ E2 xs obtain E
    where "E2 = Val v∙compareAndSwap(DF, Val v', E)" and "bisim Vs e E xs" by auto
  with IH[of Vs E xs] ‹fv _  set Vs ‹lcl s m [Vs [↦] xs] ‹extTA2J0 P,P,t  e,s -ta e',s'
    ‹length Vs + max_vars _  length xs ?synth _ s
  show ?case by(fastforce elim!: sim_move01_expr)
next
  case (CallObj e s ta e' s' M es Vs E2 xs)
  note IH = vs e2 XS. bisim vs e e2 XS; fv e  set vs; lcl s m [vs [↦] XS]; length vs + max_vars e  length XS;
            ?synth e s   ?concl e e2 s XS e' s' ta vs
  from ‹extTA2J0 P,P,t  e,s -ta e',s' have "¬ is_val e" by auto
  with ‹bisim Vs (eM(es)) E2 xs obtain E
    where "E2 = EM(compEs1 Vs es)" and "bisim Vs e E xs" and "¬ contains_insyncs es"
    by(auto simp add: compEs1_conv_map)
  with IH[of Vs E xs] ‹fv (eM(es))  set Vs ‹lcl s m [Vs [↦] xs]
    ‹length Vs + max_vars (eM(es))  length xs ?synth (eM(es)) s
  show ?case by(cases "is_val e'")(fastforce elim!: sim_move01_expr split: if_split_asm)+
next
  case (CallParams es s ta es' s' v M Vs E2 xs)
  note IH = vs es2 XS. bisims vs es es2 XS; fvs es  set vs; lcl s m [vs [↦] XS]; length vs + max_varss es  length XS;
            ?synths es s   ?concls es es2 s XS es' s' ta vs
  from ‹bisim Vs (Val vM(es)) E2 xs obtain Es 
    where "E2 = Val vM(Es)" and "bisims Vs es Es xs" by auto
  moreover from ‹extTA2J0 P,P,t  es,s [-ta→] es',s' have "¬ is_vals es" by auto
  with ?synth (Val vM(es)) s have "?synths es s" by(auto)
  moreover note IH[of Vs Es xs] ‹fv (Val vM(es))  set Vs ‹lcl s m [Vs [↦] xs] 
    ‹length Vs + max_vars (Val vM(es))  length xs
  ultimately show ?case by(fastforce elim!: sim_move01_CallParams)
next
  case (RedCall s a U M Ts T pns body D vs Vs E2 xs)
  from typeof_addr (hp s) a = U
  have "call (addr aM(map Val vs)) = (a, M, vs)" by auto
  with ?synth (addr aM(map Val vs)) s have "synthesized_call P (hp s) (a, M, vs)" by auto
  with typeof_addr (hp s) a = U P  class_type_of U sees M: TsT = (pns, body) in D
  have False by(auto simp add: synthesized_call_conv dest: sees_method_fun)
  thus ?case ..
next
  case (RedCallExternal s a T M Ts Tr D vs ta va h' ta' e' s' Vs E2 xs)
  from ‹bisim Vs (addr aM(map Val vs)) E2 xs have "E2 = addr aM(map Val vs)" by auto
  moreover note P  class_type_of T sees M: TsTr = Native in D typeof_addr (hp s) a = T ta' = extTA2J0 P ta
    e' = extRet2J (addr aM(map Val vs)) va s' = (h', lcl s) P,t  aM(vs),hp s -ta→ext va,h'
    ‹lcl s m [Vs [↦] xs]
  moreover from wf P,t  aM(vs),hp s -ta→ext va,h'
  have "ta_bisim01 (extTA2J0 P ta) (extTA2J1 (compP1 P) ta)" by(rule red_external_ta_bisim01)
  moreover from P,t  aM(vs),hp s -ta→ext va,h' typeof_addr (hp s) a = T
    P  class_type_of T sees M: TsTr = Native in D
  have "τexternal_defs D M  h' = hp s  ta = ε"
    by(fastforce dest: τexternal'_red_external_heap_unchanged τexternal'_red_external_TA_empty simp add: τexternal'_def τexternal_def)
  ultimately show ?case 
    by(cases va)(fastforce intro!: exI[where x=ta] intro: Red1CallExternal simp add: map_eq_append_conv sim_move01_def dest: sees_method_fun simp del: split_paired_Ex)+
next
  case (BlockRed e h x V vo ta e' h' x' T Vs E2 xs)
  note IH = vs e2 XS. bisim vs e e2 XS; fv e  set vs; lcl (h, x(V := vo)) m [vs [↦] XS];
                         length vs + max_vars e  length XS; ?synth e (h, (x(V := vo)))
             ?concl e e2 (h, x(V := vo)) XS e' (h', x') ta vs
  note red = ‹extTA2J0 P,P,t  e,(h, x(V := vo)) -ta e',(h', x')
  note len = ‹length Vs + max_vars {V:T=vo; e}  length xs
  from ‹fv {V:T=vo; e}  set Vs have fv: "fv e  set (Vs@[V])" by auto
  from ‹bisim Vs {V:T=vo; e} E2 xs show ?case
  proof(cases rule: bisim_cases(7)[consumes 1, case_names BlockNone BlockSome BlockSomeNone])
    case (BlockNone E')
    with red IH[of "Vs@[V]" E' xs] fv ‹lcl (h, x) m [Vs [↦] xs]
      ‹length Vs + max_vars {V:T=vo; e}  length xs ?synth {V:T=vo; e} (h, x)
    obtain TA' e2' xs' where red': "sim_move01 (compP1 P) t ta e E' h xs TA' e2' h' xs'"
      and bisim': "bisim (Vs @ [V]) e' e2' xs'" "x' m [Vs @ [V] [↦] xs']" by auto 
    from red' ‹length Vs + max_vars {V:T=vo; e}  length xs
    have "length (Vs@[V]) + max_vars e  length xs'"
      by(fastforce simp add: sim_move01_def dest: red1_preserves_len τred1t_preserves_len τred1r_preserves_len split: if_split_asm)
    with x' m [Vs @ [V] [↦] xs'] have "x' m [Vs [↦] xs', V  xs' ! length Vs]" by(simp)
    moreover 
    { assume "V  set Vs"
      hence "hidden (Vs @ [V]) (index Vs V)" by(rule hidden_index)
      with ‹bisim (Vs @ [V]) e E' xs have "unmod E' (index Vs V)"
        by -(rule hidden_bisim_unmod)
      moreover from ‹length Vs + max_vars {V:T=vo; e}  length xs V  set Vs
      have "index Vs V < length xs" by(auto intro: index_less_aux)
      ultimately have "xs ! index Vs V = xs' ! index Vs V"
        using sim_move01_preserves_unmod[OF red'] by(simp) }
    moreover from red' have "length xs = length xs'" by(rule sim_move01_preserves_len[symmetric])
    ultimately have rel: "x'(V := x V) m [Vs [↦] xs']"
      using ‹lcl (h, x) m [Vs [↦] xs] ‹length Vs + max_vars {V:T=vo; e}  length xs
      by(auto intro: Block_lem)
    show ?thesis
    proof(cases "x' V")
      case None
      with red' bisim' BlockNone len
      show ?thesis by(fastforce simp del: split_paired_Ex fun_upd_apply intro: rel)
    next
      case (Some v)
      moreover
      with x' m [Vs @ [V] [↦] xs'] have "[Vs @ [V] [↦] xs'] V = v"
        by(auto simp add: map_le_def dest: bspec)
      moreover
      from ‹length Vs + max_vars {V:T=vo; e}  length xs have "length Vs < length xs" by auto
      ultimately have "xs' ! length Vs = v" using ‹length xs = length xs' by(simp)
      with red' bisim' BlockNone Some len
      show ?thesis by(fastforce simp del: fun_upd_apply intro: rel)
    qed
  next
    case (BlockSome E' v)
    with red IH[of "Vs@[V]" E' "xs[length Vs := v]"] fv ‹lcl (h, x) m [Vs [↦] xs]
      ‹length Vs + max_vars {V:T=vo; e}  length xs ?synth {V:T=vo; e} (h, x)
    obtain TA' e2' xs' where red': "sim_move01 (compP1 P) t ta e E' h (xs[length Vs := v]) TA' e2' h' xs'"
      and bisim': "bisim (Vs @ [V]) e' e2' xs'" "x' m [Vs @ [V] [↦] xs']" by auto
    from red' ‹length Vs + max_vars {V:T=vo; e}  length xs
    have "length (Vs@[V]) + max_vars e  length xs'" by(auto dest: sim_move01_preserves_len)
    with x' m [Vs @ [V] [↦] xs'] have "x' m [Vs [↦] xs', V  xs' ! length Vs]" by(simp)
    moreover 
    { assume "V  set Vs"
      hence "hidden (Vs @ [V]) (index Vs V)" by(rule hidden_index)
      with ‹bisim (Vs @ [V]) e E' (xs[length Vs := v]) have "unmod E' (index Vs V)"
        by -(rule hidden_bisim_unmod)
      moreover from ‹length Vs + max_vars {V:T=vo; e}  length xs V  set Vs
      have "index Vs V < length xs" by(auto intro: index_less_aux)
      moreover from ‹length Vs + max_vars {V:T=vo; e}  length xs V  set Vs
      have "(xs[length Vs := v]) ! index Vs V = xs ! index Vs V" by(simp)
      ultimately have "xs ! index Vs V = xs' ! index Vs V"
        using sim_move01_preserves_unmod[OF red', of "index Vs V"] by(simp) }
    moreover from red' have "length xs = length xs'" by(auto dest: sim_move01_preserves_len)
    ultimately have rel: "x'(V := x V) m [Vs [↦] xs']"
      using ‹lcl (h, x) m [Vs [↦] xs] ‹length Vs + max_vars {V:T=vo; e}  length xs
      by(auto intro: Block_lem)
    from BlockSome red obtain v' where Some: "x' V = v'" by(auto dest!: red_lcl_incr)
    with x' m [Vs @ [V] [↦] xs'] have "[Vs @ [V] [↦] xs'] V = v'"
      by(auto simp add: map_le_def dest: bspec)
    moreover
    from ‹length Vs + max_vars {V:T=vo; e}  length xs have "length Vs < length xs" by auto
    ultimately have "xs' ! length Vs = v'" using ‹length xs = length xs' by(simp)
    with red' bisim' BlockSome Some ‹length Vs < length xs
    show ?thesis by(fastforce simp del: fun_upd_apply intro: rel)
  next 
    case (BlockSomeNone E')
    with red IH[of "Vs@[V]" E' xs] fv ‹lcl (h, x) m [Vs [↦] xs]
      ‹length Vs + max_vars {V:T=vo; e}  length xs ?synth {V:T=vo; e} (h, x)
    obtain TA' e2' xs' where red': "sim_move01 (compP1 P) t ta e E' h xs TA' e2' h' xs'"
      and IH': "bisim (Vs @ [V]) e' e2' xs'" "x' m [Vs @ [V] [↦] xs']" by auto
    from red' ‹length Vs + max_vars {V:T=vo; e}  length xs
    have "length (Vs@[V]) + max_vars e  length xs'" by(auto dest: sim_move01_preserves_len)
    with x' m [Vs @ [V] [↦] xs'] have "x' m [Vs [↦] xs', V  xs' ! length Vs]" by(simp)
    moreover 
    { assume "V  set Vs"
      hence "hidden (Vs @ [V]) (index Vs V)" by(rule hidden_index)
      with ‹bisim (Vs @ [V]) e E' xs have "unmod E' (index Vs V)"
        by -(rule hidden_bisim_unmod)
      moreover from ‹length Vs + max_vars {V:T=vo; e}  length xs V  set Vs
      have "index Vs V < length xs" by(auto intro: index_less_aux)
      moreover from ‹length Vs + max_vars {V:T=vo; e}  length xs V  set Vs
      have "(xs[length Vs := v]) ! index Vs V = xs ! index Vs V" by(simp)
      ultimately have "xs ! index Vs V = xs' ! index Vs V"
        using sim_move01_preserves_unmod[OF red', of "index Vs V"] by(simp) }
    moreover from red' have "length xs = length xs'" by(auto dest: sim_move01_preserves_len)
    ultimately have rel: "x'(V := x V) m [Vs [↦] xs']"
      using ‹lcl (h, x) m [Vs [↦] xs] ‹length Vs + max_vars {V:T=vo; e}  length xs
      by(auto intro: Block_lem)
    from BlockSomeNone red obtain v' where Some: "x' V = v'" by(auto dest!: red_lcl_incr)
    with x' m [Vs @ [V] [↦] xs'] have "[Vs @ [V] [↦] xs'] V = v'"
      by(auto simp add: map_le_def dest: bspec)
    moreover
    from ‹length Vs + max_vars {V:T=vo; e}  length xs have "length Vs < length xs" by auto
    ultimately have "xs' ! length Vs = v'" using ‹length xs = length xs' by(simp)
    with red' IH' BlockSomeNone Some ‹length Vs < length xs
    show ?thesis by(fastforce simp del: fun_upd_apply intro: rel)
  qed
next
  case (RedBlock V T vo u s Vs E2 xs)
  from ‹bisim Vs {V:T=vo; Val u} E2 xs obtain vo'
    where [simp]: "E2 = {length Vs:T=vo'; Val u}" by auto
  from RedBlock show ?case
  proof(cases vo)
    case (Some v)
    with ‹bisim Vs {V:T=vo; Val u} E2 xs
    have vo': "case vo' of None  xs ! length Vs = v | Some v'  v = v'" by auto
    have "sim_move01 (compP1 P) t ε {V:T=vo; Val u} E2 (hp s) xs ε (Val u) (hp s) (xs[length Vs := v])"
    proof(cases vo')
      case None with vo'
      have "xs[length Vs := v] = xs" by auto
      thus ?thesis using Some None by auto
    next
      case Some
      from ‹length Vs + max_vars {V:T=vo; Val u}  length xs have "length Vs < length xs" by simp
      with vo' Some show ?thesis using vo = Some v by auto
    qed
    thus ?thesis using RedBlock by fastforce
  qed fastforce
next
  case SynchronizedNull thus ?case by fastforce
next
  case (LockSynchronized a e s Vs E2 xs)
  from ‹bisim Vs (sync(addr a) e) E2 xs
  have E2: "E2 = synclength Vs (addr a) (compE1 (Vs@[fresh_var Vs]) e)" 
    and sync: "¬ contains_insync e" by auto
  moreover have "fresh_var Vs  set Vs" by(rule fresh_var_fresh)
  with ‹fv (sync(addr a) e)  set Vs have "fresh_var Vs  fv e" by auto
  from E2 ‹fv (sync(addr a) e)  set Vs sync
  have "bisim (Vs@[fresh_var Vs]) e (compE1 (Vs@[fresh_var Vs]) e) (xs[length Vs := Addr a])"
    by(auto intro!: compE1_bisim)
  hence "bisim Vs (insync(a) e) (insynclength Vs (a) (compE1 (Vs@[fresh_var Vs]) e)) (xs[length Vs := Addr a])"
    using ‹fresh_var Vs  fv e ‹length Vs + max_vars (sync(addr a) e)  length xs by auto
  moreover from ‹length Vs + max_vars (sync(addr a) e)  length xs
  have "False,compP1 P,t ⊢1 synclength Vs (addr a) (compE1 (Vs@[fresh_var Vs]) e), (hp s, xs)
        -Locka, SyncLock a
        insynclength Vs (a) (compE1 (Vs@[fresh_var Vs]) e), (hp s, xs[length Vs := Addr a])"
    by -(rule Lock1Synchronized, auto)
  hence "sim_move01 (compP1 P) t Locka, SyncLock a (sync(addr a) e) E2 (hp s) xs Locka, SyncLock a (insynclength Vs (a) (compE1 (Vs@[fresh_var Vs]) e)) (hp s) (xs[length Vs := Addr a])"
    using E2 by(fastforce simp add: sim_move01_def ta_bisim_def)
  moreover have "zip Vs (xs[length Vs := Addr a]) = (zip Vs xs)[length Vs := (arbitrary, Addr a)]"
    by(rule sym)(simp add: update_zip)
  hence "zip Vs (xs[length Vs := Addr a]) = zip Vs xs" by simp
  with ‹lcl s m [Vs [↦] xs] have "lcl s m [Vs [↦] xs[length Vs := Addr a]]"
    by(auto simp add: map_le_def map_upds_def)
  ultimately show ?case using ‹lcl s m [Vs [↦] xs] by fastforce
next
  case (SynchronizedRed2 e s ta e' s' a Vs E2 xs)
  note IH = vs e2 XS. bisim vs e e2 XS; fv e  set vs; lcl s m [vs [↦] XS]; length vs + max_vars e  length XS;
            ?synth e s   ?concl e e2 s XS e' s' ta vs
  from ‹bisim Vs (insync(a) e) E2 xs obtain E
    where E2: "E2 = insynclength Vs (a) E" and bisim: "bisim (Vs@[fresh_var Vs]) e E xs"
    and xsa: "xs ! length Vs = Addr a" by auto
  from ‹fv (insync(a) e)  set Vs fresh_var_fresh[of Vs] have fv: "fresh_var Vs  fv e" by auto
  from ‹length Vs + max_vars (insync(a) e)  length xs have "length Vs < length xs" by simp
  { assume "lcl s (fresh_var Vs)  None"
    then obtain v where "lcl s (fresh_var Vs) = v" by auto
    with ‹lcl s m [Vs [↦] xs] have "[Vs [↦] xs] (fresh_var Vs) = v" 
      by(auto simp add: map_le_def dest: bspec)
    hence "fresh_var Vs  set Vs" 
      by(auto simp add: map_upds_def set_zip dest!: map_of_SomeD )
    moreover have "fresh_var Vs  set Vs" by(rule fresh_var_fresh)
    ultimately have False by contradiction }
  hence "lcl s (fresh_var Vs) = None" by(cases "lcl s (fresh_var Vs)", auto)
  hence "(lcl s)(fresh_var Vs := None) = lcl s" by(auto intro: ext)
  moreover from ‹lcl s m [Vs [↦] xs]
  have "(lcl s)(fresh_var Vs := None) m [Vs [↦] xs, fresh_var Vs  xs ! length Vs]" by(simp)
  ultimately have "lcl s m [Vs @ [fresh_var Vs] [↦] xs]"
    using ‹length Vs < length xs by(auto)
  with IH[of "Vs@[fresh_var Vs]" E xs] ‹fv (insync(a) e)  set Vs bisim
    ‹length Vs + max_vars (insync(a) e)  length xs ?synth (insync(a) e) s 
  obtain TA' e2' xs' where IH': "sim_move01 (compP1 P) t ta e E (hp s) xs TA' e2' (hp s') xs'"
    "bisim (Vs @ [fresh_var Vs]) e' e2' xs'" "lcl s' m [Vs @ [fresh_var Vs] [↦] xs']" by auto
  from ‹extTA2J0 P,P,t  e,s -ta e',s' have "dom (lcl s')  dom (lcl s)  fv e" by(auto dest: red_dom_lcl)
  with fv ‹lcl s (fresh_var Vs) = None› have "(fresh_var Vs)  dom (lcl s')" by auto
  hence "lcl s' (fresh_var Vs) = None" by auto
  moreover from IH' have "length xs = length xs'" by(auto dest: sim_move01_preserves_len)
  moreover note ‹lcl s' m [Vs @ [fresh_var Vs] [↦] xs'] ‹length Vs < length xs
  ultimately have "lcl s' m [Vs [↦] xs']" by(auto simp add: map_le_def dest: bspec)
  moreover from bisim fv have "unmod E (length Vs)" by(auto intro: bisim_fv_unmod)
  with IH' ‹length Vs < length xs have "xs ! length Vs = xs' ! length Vs"
    by(auto dest!: sim_move01_preserves_unmod)
  with xsa have "xs' ! length Vs = Addr a" by simp
  ultimately show ?case using IH' E2 by(fastforce)
next
  case (UnlockSynchronized a v s Vs E2 xs)
  from ‹bisim Vs (insync(a) Val v) E2 xs have E2: "E2 = insynclength Vs (a) Val v" 
    and xsa: "xs ! length Vs = Addr a" by auto
  moreover from ‹length Vs + max_vars (insync(a) Val v)  length xs xsa
  have "False,compP1 P,t ⊢1 insynclength Vs (a) (Val v), (hp s, xs) -Unlocka, SyncUnlock a Val v, (hp s, xs)"
    by-(rule Unlock1Synchronized, auto)
  hence "sim_move01 (compP1 P) t Unlocka, SyncUnlock a (insync(a) Val v) (insynclength Vs (a) Val v) (hp s) xs Unlocka, SyncUnlock a (Val v) (hp s) xs"
    by(fastforce simp add: sim_move01_def ta_bisim_def)
  ultimately show ?case using ‹lcl s m [Vs [↦] xs] by fastforce
next
  case (RedWhile b c s Vs E2 xs)
  from ‹bisim Vs (while (b) c) E2 xs have "E2 = while (compE1 Vs b) (compE1 Vs c)"
    and sync: "¬ contains_insync b" "¬ contains_insync c" by auto
  moreover have "False,compP1 P,t ⊢1 while(compE1 Vs b) (compE1 Vs c), (hp s, xs) 
                 -ε if (compE1 Vs b) (compE1 Vs c;;while(compE1 Vs b) (compE1 Vs c)) else unit, (hp s, xs)"
    by(rule Red1While)
  hence "sim_move01 (compP1 P) t ε (while (b) c) (while (compE1 Vs b) (compE1 Vs c)) (hp s) xs ε (if (compE1 Vs b) (compE1 Vs c;;while(compE1 Vs b) (compE1 Vs c)) else unit) (hp s) xs"
    by(auto simp add: sim_move01_def)
  moreover from ‹fv (while (b) c)  set Vs sync
  have "bisim Vs (if (b) (c;; while (b) c) else unit)
                 (if (compE1 Vs b) (compE1 Vs (c;; while(b) c)) else (compE1 Vs unit)) xs"
    by -(rule bisimCond, auto)
  ultimately show ?case using ‹lcl s m [Vs [↦] xs]
    by(simp)((rule exI)+, erule conjI, auto)
next
  case (RedTryCatch s a D C V e2 Vs E2 xs)
  thus ?case by(auto intro!: exI)(auto intro!: compE1_bisim)
next
  case RedTryFail thus ?case by(auto intro!: exI)
next
  case (ListRed1 e s ta e' s' es Vs ES2 xs)
  note IH = vs e2 XS. bisim vs e e2 XS; fv e  set vs; lcl s m [vs [↦] XS]; length vs + max_vars e  length XS;
                         ?synth e s  ?concl e e2 s XS e' s' ta vs
  from ‹extTA2J0 P,P,t  e,s -ta e',s' have "¬ is_val e" by auto
  with ‹bisims Vs (e # es) ES2 xs obtain E' 
    where "bisim Vs e E' xs" and ES2: "ES2 = E' # compEs1 Vs es" 
    and sync: "¬ contains_insyncs es" by(auto simp add: compEs1_conv_map)
  with IH[of Vs E' xs] ‹fvs (e # es)  set Vs ‹lcl s m [Vs [↦] xs] ‹extTA2J0 P,P,t  e,s -ta e',s'
    ‹length Vs + max_varss (e # es)  length xs ?synths (e # es) s ¬ is_val e
  show ?case by(cases "is_val e'")(fastforce elim!: sim_moves01_expr split: if_split_asm)+
next
  case (ListRed2 es s ta es' s' v Vs ES2 xs)
  thus ?case by(fastforce elim!: bisims_cases elim!: sim_moves01_expr)
next
  case CallThrowParams thus ?case
    by(fastforce elim!:bisim_cases simp add: bisims_map_Val_Throw)
next
  case (BlockThrow V T vo a s Vs e2 xs) thus ?case
    by(cases vo)(fastforce elim!: bisim_cases)+
next    
  case (SynchronizedThrow2 a ad s Vs E2 xs)
  from ‹bisim Vs (insync(a) Throw ad) E2 xs have "xs ! length Vs = Addr a" by auto
  with ‹length Vs + max_vars (insync(a) Throw ad)  length xs
  have "False,compP1 P,t ⊢1 insynclength Vs (a) Throw ad, (hp s, xs) -Unlocka, SyncUnlock a Throw ad, (hp s, xs)"
    by-(rule Synchronized1Throw2, auto)
  hence "sim_move01 (compP1 P) t Unlocka, SyncUnlock a (insync(a) Throw ad) (insynclength Vs (a) Throw ad) (hp s) xs Unlocka, SyncUnlock a (Throw ad) (hp s) xs"
    by(fastforce simp add: sim_move01_def ta_bisim_def fun_eq_iff expand_finfun_eq finfun_upd_apply ta_upd_simps split: if_split_asm)
  moreover note ‹lcl s m [Vs [↦] xs] ‹bisim Vs (insync(a) Throw ad) E2 xs
  ultimately show ?case by(fastforce)
next
  case InstanceOfRed thus ?case by(fastforce)
next
  case RedInstanceOf thus ?case by(auto intro!: exI)
next
  case InstanceOfThrow thus ?case by fastforce
qed(fastforce simp del: fun_upd_apply split: if_split_asm)+

end

declare max_dest [iff del]

declare split_paired_Ex [simp del]

primrec countInitBlock :: "('a, 'b, 'addr) exp  nat"
  and countInitBlocks :: "('a, 'b, 'addr) exp list  nat"
where 
  "countInitBlock (new C) = 0"
| "countInitBlock (newA Te) = countInitBlock e"
| "countInitBlock (Cast T e) = countInitBlock e"
| "countInitBlock (e instanceof T) = countInitBlock e"
| "countInitBlock (Val v) = 0"
| "countInitBlock (Var V) = 0"
| "countInitBlock (V := e) = countInitBlock e"
| "countInitBlock (e «bop» e') = countInitBlock e + countInitBlock e'"
| "countInitBlock (ai) = countInitBlock a + countInitBlock i"
| "countInitBlock (AAss a i e) = countInitBlock a + countInitBlock i + countInitBlock e"
| "countInitBlock (a∙length) = countInitBlock a"
| "countInitBlock (eF{D}) = countInitBlock e"
| "countInitBlock (FAss e F D e') = countInitBlock e + countInitBlock e'"
| "countInitBlock (e∙compareAndSwap(DF, e', e'')) = 
   countInitBlock e + countInitBlock e' + countInitBlock e''"
| "countInitBlock (eM(es)) = countInitBlock e + countInitBlocks es"
| "countInitBlock ({V:T=vo; e}) = (case vo of None  0 | Some v  1) + countInitBlock e"
| "countInitBlock (syncV' (e) e') = countInitBlock e + countInitBlock e'"
| "countInitBlock (insyncV' (ad) e) = countInitBlock e"
| "countInitBlock (e;;e') = countInitBlock e + countInitBlock e'"
| "countInitBlock (if (e) e1 else e2) = countInitBlock e + countInitBlock e1 + countInitBlock e2"
| "countInitBlock (while(b) e) = countInitBlock b + countInitBlock e"
| "countInitBlock (throw e) = countInitBlock e"
| "countInitBlock (try e catch(C V) e') = countInitBlock e + countInitBlock e'"

| "countInitBlocks [] = 0"
| "countInitBlocks (e # es) = countInitBlock e + countInitBlocks es"

context J0_J1_heap_base begin

lemmas τred0r_expr =
  NewArray_τred0r_xt Cast_τred0r_xt InstanceOf_τred0r_xt BinOp_τred0r_xt1 BinOp_τred0r_xt2 LAss_τred0r
  AAcc_τred0r_xt1 AAcc_τred0r_xt2 AAss_τred0r_xt1 AAss_τred0r_xt2 AAss_τred0r_xt3
  ALength_τred0r_xt FAcc_τred0r_xt FAss_τred0r_xt1 FAss_τred0r_xt2
  CAS_τred0r_xt1 CAS_τred0r_xt2 CAS_τred0r_xt3 Call_τred0r_obj
  Call_τred0r_param Block_τred0r_xt Sync_τred0r_xt InSync_τred0r_xt
  Seq_τred0r_xt Cond_τred0r_xt Throw_τred0r_xt Try_τred0r_xt

lemmas τred0t_expr =
  NewArray_τred0t_xt Cast_τred0t_xt InstanceOf_τred0t_xt BinOp_τred0t_xt1 BinOp_τred0t_xt2 LAss_τred0t
  AAcc_τred0t_xt1 AAcc_τred0t_xt2 AAss_τred0t_xt1 AAss_τred0t_xt2 AAss_τred0t_xt3
  ALength_τred0t_xt FAcc_τred0t_xt FAss_τred0t_xt1 FAss_τred0t_xt2
  CAS_τred0t_xt1 CAS_τred0t_xt2 CAS_τred0t_xt3 Call_τred0t_obj
  Call_τred0t_param Block_τred0t_xt Sync_τred0t_xt InSync_τred0t_xt
  Seq_τred0t_xt Cond_τred0t_xt Throw_τred0t_xt Try_τred0t_xt

declare τred0r_expr [elim!]
declare τred0t_expr [elim!]

definition sim_move10 :: 
  "'addr J_prog  'thread_id  ('addr, 'thread_id, 'heap) external_thread_action  'addr expr1  'addr expr1  'addr expr
   'heap  'addr locals  ('addr, 'thread_id, 'heap) J0_thread_action  'addr expr  'heap  'addr locals  bool"
where
  "sim_move10 P t ta1 e1 e1' e h xs ta e' h' xs'  ¬ final e1 
  (if τmove1 P h e1 then (τred0t (extTA2J0 P) P t h (e, xs) (e', xs')  countInitBlock e1' < countInitBlock e1  e' = e  xs' = xs)  h' = h  ta1 = ε  ta = ε
   else ta_bisim01 ta (extTA2J1 (compP1 P) ta1) 
     (if call e = None  call1 e1 = None 
      then (e'' xs''. τred0r (extTA2J0 P) P t h (e, xs) (e'', xs'')  extTA2J0 P,P,t  e'', (h, xs'') -ta e', (h', xs')  no_call P h e''  ¬ τmove0 P h e'')
      else extTA2J0 P,P,t  e, (h, xs) -ta e', (h', xs')  no_call P h e  ¬ τmove0 P h e))"

definition sim_moves10 :: 
  "'addr J_prog  'thread_id  ('addr, 'thread_id, 'heap) external_thread_action  'addr expr1 list  'addr expr1 list
   'addr expr list  'heap  'addr locals  ('addr, 'thread_id, 'heap) J0_thread_action  'addr expr list  'heap 
   'addr locals  bool"
where
  "sim_moves10 P t ta1 es1 es1' es h xs ta es' h' xs'  ¬ finals es1 
  (if τmoves1 P h es1 then (τreds0t (extTA2J0 P) P t h (es, xs) (es', xs')  countInitBlocks es1' < countInitBlocks es1  es' = es  xs' = xs)  h' = h  ta1 = ε  ta = ε
   else ta_bisim01 ta (extTA2J1 (compP1 P) ta1) 
     (if calls es = None  calls1 es1 = None
      then (es'' xs''. τreds0r (extTA2J0 P) P t h (es, xs) (es'', xs'')  extTA2J0 P,P,t  es'', (h, xs'') [-ta→] es', (h', xs')  no_calls P h es''  ¬ τmoves0 P h es'')
      else extTA2J0 P,P,t  es, (h, xs) [-ta→] es', (h', xs')  no_calls P h es  ¬ τmoves0 P h es))"

lemma sim_move10_expr:
  assumes "sim_move10 P t ta1 e1 e1' e h xs ta e' h' xs'"
  shows
  "sim_move10 P t ta1 (newA Te1) (newA Te1') (newA Te) h xs ta (newA Te') h' xs'"
  "sim_move10 P t ta1 (Cast T e1) (Cast T e1') (Cast T e) h xs ta (Cast T e') h' xs'"
  "sim_move10 P t ta1 (e1 instanceof T) (e1' instanceof T) (e instanceof T) h xs ta (e' instanceof T) h' xs'"
  "sim_move10 P t ta1 (e1 «bop» e2) (e1' «bop» e2) (e «bop» e2') h xs ta (e' «bop» e2') h' xs'"
  "sim_move10 P t ta1 (Val v «bop» e1) (Val v «bop» e1') (Val v «bop» e) h xs ta (Val v «bop» e') h' xs'"
  "sim_move10 P t ta1 (V := e1) (V := e1') (V' := e) h xs ta (V' := e') h' xs'"
  "sim_move10 P t ta1 (e1e2) (e1'e2) (ee2') h xs ta (e'e2') h' xs'"
  "sim_move10 P t ta1 (Val ve1) (Val ve1') (Val ve) h xs ta (Val ve') h' xs'"
  "sim_move10 P t ta1 (e1e2 := e3) (e1'e2 := e3) (ee2' := e3') h xs ta (e'e2' := e3') h' xs'"
  "sim_move10 P t ta1 (Val ve1 := e3) (Val ve1' := e3) (Val ve := e3') h xs ta (Val ve' := e3') h' xs'"
  "sim_move10 P t ta1 (AAss (Val v) (Val v') e1) (AAss (Val v) (Val v') e1') (AAss (Val v) (Val v') e) h xs ta (AAss (Val v) (Val v') e') h' xs'"
  "sim_move10 P t ta1 (e1∙length) (e1'∙length) (e∙length) h xs ta (e'∙length) h' xs'"
  "sim_move10 P t ta1 (e1F{D}) (e1'F{D}) (eF'{D'}) h xs ta (e'F'{D'}) h' xs'"
  "sim_move10 P t ta1 (FAss e1 F D e2) (FAss e1' F D e2) (FAss e F' D' e2') h xs ta (FAss e' F' D' e2') h' xs'"
  "sim_move10 P t ta1 (FAss (Val v) F D e1) (FAss (Val v) F D e1') (FAss (Val v) F' D' e) h xs ta (FAss (Val v) F' D' e') h' xs'"
  "sim_move10 P t ta1 (CompareAndSwap e1 F D e2 e3) (CompareAndSwap e1' F D e2 e3) (CompareAndSwap e F' D' e2' e3') h xs ta (CompareAndSwap e' F' D' e2' e3') h' xs'"
  "sim_move10 P t ta1 (CompareAndSwap (Val v) F D e1 e3) (CompareAndSwap (Val v) F D e1' e3) (CompareAndSwap (Val v) F' D' e e3') h xs ta (CompareAndSwap (Val v) F' D' e' e3') h' xs'"
  "sim_move10 P t ta1 (CompareAndSwap (Val v) F D (Val v') e1) (CompareAndSwap (Val v) F D (Val v') e1') (CompareAndSwap (Val v) F' D' (Val v') e) h xs ta (CompareAndSwap (Val v) F' D' (Val v') e') h' xs'"
  "sim_move10 P t ta1 (e1M(es)) (e1'M(es)) (eM(es')) h xs ta (e'M(es')) h' xs'"
  "sim_move10 P t ta1 (syncV(e1) e2) (syncV(e1') e2) (sync(e) e2') h xs ta (sync(e') e2') h' xs'"
  "sim_move10 P t ta1 (insyncV(a) e1) (insyncV(a) e1') (insync(a') e) h xs ta (insync(a') e') h' xs'"
  "sim_move10 P t ta1 (e1;;e2) (e1';;e2) (e;;e2') h xs ta (e';;e2') h' xs'"
  "sim_move10 P t ta1 (if (e1) e2 else e3) (if (e1') e2 else e3) (if (e) e2' else e3') h xs ta (if (e') e2' else e3') h' xs'"
  "sim_move10 P t ta1 (throw e1) (throw e1') (throw e) h xs ta (throw e') h' xs'"
  "sim_move10 P t ta1 (try e1 catch(C V) e2) (try e1' catch(C V) e2) (try e catch(C' V') e2') h xs ta (try e' catch(C' V') e2') h' xs'"
using assms
apply(simp_all add: sim_move10_def final_iff split del: if_split split: if_split_asm)
apply(fastforce simp: τred0t_Val τred0r_Val intro: red_reds.intros split!: if_splits)+
done

lemma sim_moves10_expr:
  "sim_move10 P t ta1 e1 e1' e h xs ta e' h' xs'  sim_moves10 P t ta1 (e1 # es2) (e1' # es2) (e # es2') h xs ta (e' # es2') h' xs'"
  "sim_moves10 P t ta1 es1 es1' es h xs ta es' h' xs'  sim_moves10 P t ta1 (Val v # es1) (Val v # es1') (Val v # es) h xs ta (Val v # es') h' xs'"
unfolding sim_moves10_def sim_move10_def final_iff finals_iff
apply(simp_all add: Cons_eq_append_conv split del: if_split split: if_split_asm)
apply(safe intro!: if_split)
apply(fastforce simp add: is_vals_conv τreds0t_map_Val τreds0r_map_Val τred0t_Val τred0r_Val intro!: τred0r_inj_τreds0r τreds0r_cons_τreds0r τred0t_inj_τreds0t τreds0t_cons_τreds0t ListRed1 ListRed2 split: if_split_asm)+
done

lemma sim_move10_CallParams:
  "sim_moves10 P t ta1 es1 es1' es h xs ta es' h' xs'
   sim_move10 P t ta1 (Val vM(es1)) (Val vM(es1')) (Val vM(es)) h xs ta (Val vM(es')) h' xs'"
unfolding sim_move10_def sim_moves10_def
apply(simp split: if_split_asm split del: if_split add: is_vals_conv)
  apply(fastforce simp add: τred0t_Val τred0r_Val τreds0t_map_Val τreds0r_map_Val intro: Call_τred0r_param Call_τred0t_param CallParams split: if_split_asm split del: if_split intro!: if_split)
 apply(rule conjI)
  apply fastforce
 apply(rule if_intro)
  apply fastforce
 apply(clarsimp split del: if_split)
 apply(rule if_intro)
  apply(clarsimp split: if_split_asm simp add: is_vals_conv)
   apply(rule exI conjI)+
    apply(erule Call_τred0r_param)
   apply(fastforce intro: CallParams)
  apply(rule exI conjI)+
   apply(erule Call_τred0r_param)
  apply(fastforce intro!: CallParams)
 apply(clarsimp split del: if_split split: if_split_asm simp add: is_vals_conv τreds0r_map_Val)
 apply fastforce
apply(rule conjI)
 apply fastforce
apply(rule if_intro)
 apply fastforce
apply(rule conjI)
 apply fastforce
apply(rule if_intro)
 apply(clarsimp split: if_split_asm)
apply(clarsimp split: if_split_asm split del: if_split simp add: is_vals_conv)
apply(fastforce intro: CallParams)
done

lemma sim_move10_Block:
  "sim_move10 P t ta1 e1 e1' e h (xs(V' := vo)) ta e' h' xs'
   sim_move10 P t ta1 ({V:T=None; e1}) ({V:T=None; e1'}) ({V':T=vo; e}) h xs ta ({V':T=xs' V'; e'}) h' (xs'(V' := xs V'))"
proof -
  assume "sim_move10 P t ta1 e1 e1' e h (xs(V' := vo)) ta e' h' xs'"
  moreover {
    fix e'' xs''
    assume "extTA2J0 P,P,t  e'',(h, xs'') -ta e',(h', xs')"
    hence "extTA2J0 P,P,t  e'',(h, xs''(V' := xs V', V' := xs'' V')) -ta e',(h', xs')" by simp
    from BlockRed[OF this, of T]
    have "extTA2J0 P,P,t  {V':T=xs'' V'; e''},(h, xs''(V' := xs V')) -ta {V':T=xs' V'; e'},(h', xs'(V' := xs V'))"
      by simp }
  ultimately show ?thesis
    by(fastforce simp add: sim_move10_def final_iff split: if_split_asm)
qed

lemma sim_move10_reds:
  " (h', a)  allocate h (Class_type C); ta1 = NewHeapElem a (Class_type C); ta = NewHeapElem a (Class_type C) 
   sim_move10 P t ta1 (new C) e1' (new C) h xs ta (addr a) h' xs"
  "allocate h (Class_type C) = {}  sim_move10 P t ε (new C) e1' (new C) h xs ε (THROW OutOfMemory) h xs"
  " (h', a)  allocate h (Array_type T (nat (sint i))); 0 <=s i;
     ta1 = NewHeapElem a (Array_type T (nat (sint i))); ta = NewHeapElem a (Array_type T (nat (sint i))) 
   sim_move10 P t ta1 (newA TVal (Intg i)) e1' (newA TVal (Intg i)) h xs ta (addr a) h' xs"
  "i <s 0  sim_move10 P t ε (newA TVal (Intg i)) e1' (newA TVal (Intg i)) h xs ε (THROW NegativeArraySize) h xs"
  " allocate h (Array_type T (nat (sint i))) = {}; 0 <=s i 
   sim_move10 P t ε (newA TVal (Intg i)) e1' (newA TVal (Intg i)) h xs ε (THROW OutOfMemory) h xs"
  " typeofh v = U; P  U  T 
   sim_move10 P t ε (Cast T (Val v)) e1' (Cast T (Val v)) h xs ε (Val v) h xs"
  " typeofh v = U; ¬ P  U  T 
   sim_move10 P t ε (Cast T (Val v)) e1' (Cast T (Val v)) h xs ε (THROW ClassCast) h xs"
  " typeofh v = U; b  v  Null  P  U  T 
   sim_move10 P t ε ((Val v) instanceof T) e1' ((Val v) instanceof T) h xs ε (Val (Bool b)) h xs"
  "binop bop v1 v2 = Some (Inl v)  sim_move10 P t ε ((Val v1) «bop» (Val v2)) e1' (Val v1 «bop» Val v2) h xs ε (Val v) h xs"
  "binop bop v1 v2 = Some (Inr a)  sim_move10 P t ε ((Val v1) «bop» (Val v2)) e1' (Val v1 «bop» Val v2) h xs ε (Throw a) h xs"
  "xs V = v  sim_move10 P t ε (Var V') e1' (Var V) h xs ε (Val v) h xs"
  "sim_move10 P t ε (V' := Val v) e1' (V := Val v) h xs ε unit h (xs(V  v))"
  "sim_move10 P t ε (nullVal v) e1' (nullVal v) h xs ε (THROW NullPointer) h xs"
  " typeof_addr h a = Array_type T n; i <s 0  sint i  int n 
   sim_move10 P t ε (addr aVal (Intg i)) e1' ((addr a)Val (Intg i)) h xs ε (THROW ArrayIndexOutOfBounds) h xs"
  " typeof_addr h a = Array_type T n; 0 <=s i; sint i < int n;
     heap_read h a (ACell (nat (sint i))) v;
     ta1 = ReadMem a (ACell (nat (sint i))) v; ta = ReadMem a (ACell (nat (sint i))) v 
   sim_move10 P t ta1 (addr aVal (Intg i)) e1' ((addr a)Val (Intg i)) h xs ta (Val v) h xs"
  "sim_move10 P t ε (nullVal v := Val v') e1' (nullVal v := Val v') h xs ε (THROW NullPointer) h xs"
  " typeof_addr h a = Array_type T n; i <s 0  sint i  int n 
   sim_move10 P t ε (AAss (addr a) (Val (Intg i)) (Val v)) e1' (AAss (addr a) (Val (Intg i)) (Val v)) h xs ε (THROW ArrayIndexOutOfBounds) h xs"
 " typeof_addr h a = Array_type T n; 0 <=s i; sint i < int n; typeofh v = U; ¬ (P  U  T) 
   sim_move10 P t ε (AAss (addr a) (Val (Intg i)) (Val v)) e1' (AAss (addr a) (Val (Intg i)) (Val v)) h xs ε (THROW ArrayStore) h xs"
  " typeof_addr h a = Array_type T n; 0 <=s i; sint i < int n; typeofh v = Some U; P  U  T;
     heap_write h a (ACell (nat (sint i))) v h';
     ta1 = WriteMem a (ACell (nat (sint i))) v; ta = WriteMem a (ACell (nat (sint i))) v 
   sim_move10 P t ta1 (AAss (addr a) (Val (Intg i)) (Val v)) e1' (AAss (addr a) (Val (Intg i)) (Val v)) h xs ta unit h' xs"
  "typeof_addr h a = Array_type T n  sim_move10 P t ε (addr a∙length) e1' (addr a∙length) h xs ε (Val (Intg (word_of_nat n))) h xs"
  "sim_move10 P t ε (null∙length) e1' (null∙length) h xs ε (THROW NullPointer) h xs"
  " heap_read h a (CField D F) v; ta1 = ReadMem a (CField D F) v; ta = ReadMem a (CField D F) v 
   sim_move10 P t ta1 (addr aF{D}) e1' (addr aF{D}) h xs ta (Val v) h xs"
  "sim_move10 P t ε (nullF{D}) e1' (nullF{D}) h xs ε (THROW NullPointer) h xs"
  " heap_write h a (CField D F) v h'; ta1 = WriteMem a (CField D F) v; ta = WriteMem a (CField D F) v 
   sim_move10 P t ta1 (addr aF{D} := Val v) e1' (addr aF{D} := Val v) h xs ta unit h' xs"
  "sim_move10 P t ε (null∙compareAndSwap(DF, Val v, Val v')) e1' (null∙compareAndSwap(DF, Val v, Val v')) h xs ε (THROW NullPointer) h xs"
  " heap_read h a (CField D F) v''; heap_write h a (CField D F) v' h'; v'' = v;
     ta1 =  ReadMem a (CField D F) v'', WriteMem a (CField D F) v' ; ta =  ReadMem a (CField D F) v'', WriteMem a (CField D F) v'  
   sim_move10 P t ta1 (addr a∙compareAndSwap(DF, Val v, Val v')) e1' (addr a∙compareAndSwap(DF, Val v, Val v')) h xs ta true h' xs"
  " heap_read h a (CField D F) v''; v''  v;
     ta1 =  ReadMem a (CField D F) v'' ; ta =  ReadMem a (CField D F) v''  
   sim_move10 P t ta1 (addr a∙compareAndSwap(DF, Val v, Val v')) e1' (addr a∙compareAndSwap(DF, Val v, Val v')) h xs ta false h xs"

  "sim_move10 P t ε (nullF{D} := Val v) e1' (nullF{D} := Val v) h xs ε (THROW NullPointer) h xs"
  "sim_move10 P t ε ({V':T=None; Val u}) e1' ({V:T=vo; Val u}) h xs ε (Val u) h xs"
  "sim_move10 P t ε ({V':T=v; e}) ({V':T=None; e}) ({V:T=vo; e'}) h xs ε ({V:T=vo; e'}) h xs"

  "sim_move10 P t ε (syncV'(null) e0) e1' (sync(null) e1) h xs ε (THROW NullPointer) h xs"
  "sim_move10 P t ε (Val v;;e0) e1' (Val v;; e1) h xs ε e1 h xs"
  "sim_move10 P t ε (if (true) e0 else e0') e1' (if (true) e1 else e2) h xs ε e1 h xs"
  "sim_move10 P t ε (if (false) e0 else e0') e1' (if (false) e1 else e2) h xs ε e2 h xs"
  "sim_move10 P t ε (throw null) e1' (throw null) h xs ε (THROW NullPointer) h xs"
  "sim_move10 P t ε (try (Val v) catch(C V') e0) e1' (try (Val v) catch(C V) e1) h xs ε (Val v) h xs"
  " typeof_addr h a = Class_type D; P  D * C 
   sim_move10 P t ε (try (Throw a) catch(C V') e0) e1' (try (Throw a) catch(C V) e1) h xs ε ({V:Class C=Addr a; e1}) h xs"
  "sim_move10 P t ε (newA TThrow a) e1' (newA TThrow a) h xs ε (Throw a) h xs"
  "sim_move10 P t ε (Cast T (Throw a)) e1' (Cast T (Throw a)) h xs ε (Throw a) h xs"
  "sim_move10 P t ε ((Throw a) instanceof T) e1' ((Throw a) instanceof T) h xs ε (Throw a) h xs"
  "sim_move10 P t ε ((Throw a) «bop» e0) e1' ((Throw a) «bop» e1) h xs ε (Throw a) h xs"
  "sim_move10 P t ε (Val v «bop» (Throw a)) e1' (Val v «bop» (Throw a)) h xs ε (Throw a) h xs"
  "sim_move10 P t ε (V' := Throw a) e1' (V := Throw a) h xs ε (Throw a) h xs"
  "sim_move10 P t ε (Throw ae0) e1' (Throw ae1) h xs ε (Throw a) h xs"
  "sim_move10 P t ε (Val vThrow a) e1' (Val vThrow a) h xs ε (Throw a) h xs"
  "sim_move10 P t ε (Throw ae0 := e0') e1' (Throw ae1 := e2) h xs ε (Throw a) h xs"
  "sim_move10 P t ε (Val vThrow a := e0) e1' (Val vThrow a := e1) h xs ε (Throw a) h xs"
  "sim_move10 P t ε (Val vVal v' := Throw a) e1' (Val vVal v' := Throw a) h xs ε (Throw a) h xs"
  "sim_move10 P t ε (Throw a∙length) e1' (Throw a∙length) h xs ε (Throw a) h xs"
  "sim_move10 P t ε (Throw aF{D}) e1' (Throw aF{D}) h xs ε (Throw a) h xs"
  "sim_move10 P t ε (Throw aF{D} := e0) e1' (Throw aF{D} := e1) h xs ε (Throw a) h xs"
  "sim_move10 P t ε (Val vF{D} := Throw a) e1' (Val vF{D} := Throw a) h xs ε (Throw a) h xs"
  "sim_move10 P t ε (CompareAndSwap (Throw a) D F e0 e0') e1' (Throw a∙compareAndSwap(DF, e1'', e1''')) h xs ε (Throw a) h xs"
  "sim_move10 P t ε (CompareAndSwap (Val v) D F (Throw a) e0') e1' (Val v∙compareAndSwap(DF, Throw a, e1'')) h xs ε (Throw a) h xs"
  "sim_move10 P t ε (CompareAndSwap (Val v) D F (Val v') (Throw a)) e1' (Val v∙compareAndSwap(DF, Val v', Throw a)) h xs ε (Throw a) h xs"
  "sim_move10 P t ε (Throw aM(es0)) e1' (Throw aM(es1)) h xs ε (Throw a) h xs"
  "sim_move10 P t ε (Val vM(map Val vs @ Throw a # es0)) e1' (Val vM(map Val vs @ Throw a # es1)) h xs ε (Throw a) h xs"
  "sim_move10 P t ε ({V':T=None; Throw a}) e1' ({V:T=vo; Throw a}) h xs ε (Throw a) h xs"
  "sim_move10 P t ε (syncV'(Throw a) e0) e1' (sync(Throw a) e1) h xs ε (Throw a) h xs"
  "sim_move10 P t ε (Throw a;;e0) e1' (Throw a;;e1) h xs ε (Throw a) h xs"
  "sim_move10 P t ε (if (Throw a) e0 else e0') e1' (if (Throw a) e1 else e2) h xs ε (Throw a) h xs"
  "sim_move10 P t ε (throw (Throw a)) e1' (throw (Throw a)) h xs ε (Throw a) h xs"
apply(fastforce simp add: sim_move10_def no_calls_def no_call_def ta_bisim_def intro: red_reds.intros)+
done

lemma sim_move10_CallNull:
  "sim_move10 P t ε (nullM(map Val vs)) e1' (nullM(map Val vs)) h xs ε (THROW NullPointer) h xs"
by(fastforce simp add: sim_move10_def map_eq_append_conv intro: RedCallNull)

lemma sim_move10_SyncLocks:
  " ta1 = Locka, SyncLock a; ta = Locka, SyncLock a 
    sim_move10 P t ta1 (syncV(addr a) e0) e1' (sync(addr a) e1) h xs ta (insync(a) e1) h xs"
  " ta1 = Unlocka, SyncUnlock a; ta = Unlocka, SyncUnlock a 
   sim_move10 P t ta1 (insyncV(a') (Val v)) e1' (insync(a) (Val v)) h xs ta (Val v) h xs"
  " ta1 = Unlocka, SyncUnlock a; ta = Unlocka, SyncUnlock a 
   sim_move10 P t ta1 (insyncV(a') (Throw a'')) e1' (insync(a) (Throw a'')) h xs ta (Throw a'') h xs"
by(fastforce simp add: sim_move10_def ta_bisim_def ta_upd_simps intro: red_reds.intros[simplified])+

lemma sim_move10_TryFail:
  " typeof_addr h a = Class_type D; ¬ P  D * C 
   sim_move10 P t ε (try (Throw a) catch(C V') e0) e1' (try (Throw a) catch(C V) e1) h xs ε (Throw a) h xs"
by(auto simp add: sim_move10_def intro!: RedTryFail)

lemmas sim_move10_intros =
  sim_move10_expr sim_move10_reds sim_move10_CallNull sim_move10_TryFail sim_move10_Block sim_move10_CallParams

lemma sim_move10_preserves_defass:
  assumes wf: "wf_J_prog P"
  shows " sim_move10 P t ta1 e1 e1' e h xs ta e' h' xs'; 𝒟 e dom xs   𝒟 e' dom xs'"
by(auto simp add: sim_move10_def split: if_split_asm dest!: τred0r_preserves_defass[OF wf] τred0t_preserves_defass[OF wf] red_preserves_defass[OF wf])

declare sim_move10_intros[intro]

lemma assumes wf: "wf_J_prog P"
  shows red_simulates_red1_aux:
  " False,compP1 P,t ⊢1 e1, S -TA e1', S'; bisim vs e2 e1 (lcl S); fv e2  set vs;
     x m [vs [↦] lcl S]; length vs + max_vars e1  length (lcl S);
     𝒟 e2 dom x 
   ta e2' x'. sim_move10 P t TA e1 e1' e2 (hp S) x ta e2' (hp S') x'  bisim vs e2' e1' (lcl S')  x' m [vs [↦] lcl S']"
  (is " _; _; _; _; _; _   ?concl e1 e1' e2 S x TA S' e1' vs")

  and reds_simulates_reds1_aux:
  " False,compP1 P,t ⊢1 es1, S [-TA→] es1', S'; bisims vs es2 es1 (lcl S); fvs es2  set vs;
     x m [vs [↦] lcl S]; length vs + max_varss es1  length (lcl S);
     𝒟s es2 dom x 
   ta es2' x'. sim_moves10 P t TA es1 es1' es2 (hp S) x ta es2' (hp S') x'  bisims vs es2' es1' (lcl S')  x' m [vs [↦] lcl S']"
  (is " _; _; _; _; _; _   ?concls es1 es1' es2 S x TA S' es1' vs")
proof(induct arbitrary: vs e2 x and vs es2 x rule: red1_reds1.inducts)
  case (Bin1OpRed1 e s ta e' s' bop e2 Vs E2 X)
  note IH = vs e2 x.  bisim vs e2 e (lcl s); fv e2  set vs;
             x m [vs [↦] lcl s]; length vs + max_vars e  length (lcl s); 𝒟 e2 dom x
              ?concl e e' e2 s x ta s' e' vs
  from ‹False,compP1 P,t ⊢1 e,s -ta e',s' have "¬ is_val e" by auto
  with ‹bisim Vs E2 (e «bop» e2) (lcl s) obtain E E2'
    where E2: "E2 = E «bop» E2'" "e2 = compE1 Vs E2'" and "bisim Vs E e (lcl s)"
    and sync: "¬ contains_insync E2'"
    by(auto elim!: bisim_cases)
  moreover note IH[of Vs E X] ‹fv E2  set Vs X m [Vs [↦] lcl s]
    ‹length Vs + max_vars (e «bop» e2)  length (lcl s) ‹𝒟 E2 dom X
  ultimately obtain TA' e2' x' where "sim_move10 P t ta e e' E (hp s) X TA' e2' (hp s') x'"
    "bisim Vs e2' e' (lcl s')" "x' m [Vs [↦] lcl s']" by(auto)
  with E2 ‹fv E2  set Vs sync show ?case by(cases "is_val e2'")(auto intro: BinOpRed1)
next
  case (Bin1OpRed2 e s ta e' s' v bop Vs E2 X)
  note IH = vs e2 x.  bisim vs e2 e (lcl s); fv e2  set vs;
             x m [vs [↦] lcl s]; length vs + max_vars e  length (lcl s); 𝒟 e2 dom x
               ?concl e e' e2 s x ta s' e' vs
  from ‹bisim Vs E2 (Val v «bop» e) (lcl s) obtain E 
    where E2: "E2 = Val v «bop» E" and "bisim Vs E e (lcl s)" by(auto)
  moreover note IH[of Vs E X] ‹fv E2  set Vs X m [Vs [↦] lcl s]
    ‹length Vs + max_vars (Val v «bop» e)  length (lcl s) ‹𝒟 E2 dom X E2
  ultimately show ?case by(auto intro: BinOpRed2)
next
  case (Red1Var s V v Vs E2 X)
  from ‹bisim Vs E2 (Var V) (lcl s) ‹fv E2  set Vs
  obtain V' where "E2 = Var V'" "V' = Vs ! V" "V = index Vs V'" by(clarify, simp)
  from E2 = Var V' ‹𝒟 E2 dom X
  obtain v' where "X V' = v'" by(auto simp add: hyperset_defs)
  with X m [Vs [↦] lcl s] have "[Vs [↦] lcl s] V' = v'" by(rule map_le_SomeD)
  with ‹length Vs + max_vars (Var V)  length (lcl s)
  have "lcl s ! (index Vs V') = v'" by(auto intro: map_upds_Some_eq_nth_index)
  with V = index Vs V' ‹lcl s ! V = v have "v = v'" by simp
  with X V' = v' E2 = Var V' X m [Vs [↦] lcl s]
  show ?case by(fastforce intro: RedVar)
next
  case (LAss1Red e s ta e' s' V Vs E2 X)
  note IH = vs e2 x.  bisim vs e2 e (lcl s); fv e2  set vs;
             x m [vs [↦] lcl s]; length vs + max_vars e  length (lcl s); 𝒟 e2 dom x
             ?concl e e' e2 s x ta s' e' vs
  from ‹bisim Vs E2 (V:=e) (lcl s) obtain E V'
    where E2: "E2 = (V':=E)" "V = index Vs V'" and "bisim Vs E e (lcl s)" by auto
  with IH[of Vs E X] ‹fv E2  set Vs X m [Vs [↦] lcl s]
    ‹length Vs + max_vars (V:=e)  length (lcl s) ‹𝒟 E2 dom X
    E2 show ?case by(auto intro: LAssRed)
next
  case (Red1LAss V l v h Vs E2 X)
  from ‹bisim Vs E2 (V:=Val v) (lcl (h, l)) obtain V' where "E2 = (V' := Val v)" "V = index Vs V'" by(auto)
  moreover with ‹fv E2  set Vs X m [Vs [↦] lcl (h, l)] ‹length Vs + max_vars (V:=Val v)  length (lcl (h, l))
  have "X(V'  v) m [Vs [↦] l[index Vs V' := v]]" by(auto intro: LAss_lem)
  ultimately show ?case by(auto intro: RedLAss simp del: fun_upd_apply)
next
  case (AAcc1Red1 a s ta a' s' i Vs E2 X)
  note IH = vs e2 x.  bisim vs e2 a (lcl s); fv e2  set vs;
             x m [vs [↦] lcl s]; length vs + max_vars a  length (lcl s); 𝒟 e2 dom x
              ?concl a a' e2 s x ta s' a' vs
  from ‹False,compP1 P,t ⊢1 a,s -ta a',s' have "¬ is_val a" by auto
  with ‹bisim Vs E2 (ai) (lcl s) obtain E E2'
    where E2: "E2 = EE2'" "i = compE1 Vs E2'" and "bisim Vs E a (lcl s)"
    and sync: "¬ contains_insync E2'" by(fastforce)
  moreover note IH[of Vs E X] ‹fv E2  set Vs X m [Vs [↦] lcl s]
    ‹length Vs + max_vars (ai)  length (lcl s) ‹𝒟 E2 dom X
  ultimately obtain TA' e2' x' where "sim_move10 P t ta a a' E (hp s) X TA' e2' (hp s') x'"
    "bisim Vs e2' a' (lcl s')" "x' m [Vs [↦] lcl s']" by(auto)
  with E2 ‹fv E2  set Vs sync show ?case
    by(cases "is_val e2'")(auto intro: AAccRed1)
next
  case (AAcc1Red2 i s ta i' s' a Vs E2 X)
  note IH = vs e2 x.  bisim vs e2 i (lcl s); fv e2  set vs;
             x m [vs [↦] lcl s]; length vs + max_vars i  length (lcl s); 𝒟 e2 dom x
             ?concl i i' e2 s x ta s' i' vs
  from ‹bisim Vs E2 (Val ai) (lcl s) obtain E 
    where E2: "E2 = Val aE" and "bisim Vs E i (lcl s)" by(auto)
  moreover note IH[of Vs E X] ‹fv E2  set Vs X m [Vs [↦] lcl s] E2
    ‹length Vs + max_vars (Val ai)  length (lcl s) ‹𝒟 E2 dom X
  ultimately show ?case by(auto intro: AAccRed2)
next
  case Red1AAcc thus ?case by(fastforce intro: RedAAcc simp del: fun_upd_apply)
next
  case (AAss1Red1 a s ta a' s' i e Vs E2 X)
  note IH = vs e2 x.  bisim vs e2 a (lcl s); fv e2  set vs;
             x m [vs [↦] lcl s]; length vs + max_vars a  length (lcl s); 𝒟 e2 dom x 
              ?concl a a' e2 s x ta s' a' vs
  from ‹False,compP1 P,t ⊢1 a,s -ta a',s' have "¬ is_val a" by auto
  with ‹bisim Vs E2 (ai:=e) (lcl s) obtain E E2' E2''
    where E2: "E2 = EE2':=E2''" "i = compE1 Vs E2'" "e = compE1 Vs E2''" and "bisim Vs E a (lcl s)"
    and sync: "¬ contains_insync E2'" "¬ contains_insync E2''" by(fastforce)
  moreover note IH[of Vs E X] ‹fv E2  set Vs X m [Vs [↦] lcl s]
    ‹length Vs + max_vars (ai:=e)  length (lcl s) ‹𝒟 E2 dom X
  ultimately obtain TA' e2' x' where IH': "sim_move10 P t ta a a' E (hp s) X TA' e2' (hp s') x'"
    "bisim Vs e2' a' (lcl s')" "x' m [Vs [↦] lcl s']" by(auto)
  show ?case
  proof(cases "is_val e2'")
    case True
    from E2 ‹fv E2  set Vs sync have "bisim Vs E2' i (lcl s')" "bisim Vs E2'' e (lcl s')" by auto
    with IH' E2 True sync show ?thesis
      by(cases "is_val E2'")(fastforce intro: AAssRed1)+
  next
    case False with IH' E2 sync show ?thesis by(fastforce intro: AAssRed1)
  qed
next
  case (AAss1Red2 i s ta i' s' a e Vs E2 X)
  note IH = vs e2 x.  bisim vs e2 i (lcl s); fv e2  set vs;
             x m [vs [↦] lcl s]; length vs + max_vars i  length (lcl s); 𝒟 e2 dom x
             ?concl i i' e2 s x ta s' i' vs
  from ‹False,compP1 P,t ⊢1 i,s -ta i',s' have "¬ is_val i" by auto
  with ‹bisim Vs E2 (Val ai:=e) (lcl s) obtain E E2'
    where E2: "E2 = Val aE:=E2'" "e = compE1 Vs E2'" and "bisim Vs E i (lcl s)"
    and sync: "¬ contains_insync E2'" by(fastforce)
  moreover note IH[of Vs E X] ‹fv E2  set Vs X m [Vs [↦] lcl s]
    ‹length Vs + max_vars (Val ai:=e)  length (lcl s) ‹𝒟 E2 dom X
  ultimately obtain TA' e2' x' where "sim_move10 P t ta i i' E (hp s) X TA' e2' (hp s') x'"
    "bisim Vs e2' i' (lcl s')" "x' m [Vs [↦] lcl s']" by(auto)
  with E2 ‹fv E2  set Vs sync show ?case
    by(cases "is_val e2'")(fastforce intro: AAssRed2)+
next
  case (AAss1Red3 e s ta e' s' a i Vs E2 X)
  note IH = vs e2 x.  bisim vs e2 e (lcl s); fv e2  set vs;
             x m [vs [↦] lcl s]; length vs + max_vars e  length (lcl s); 𝒟 e2 dom x
             ?concl e e' e2 s x ta s' e' vs
  from ‹bisim Vs E2 (Val aVal i:=e) (lcl s) obtain E
    where E2: "E2 = Val aVal i:=E" and "bisim Vs E e (lcl s)" by(fastforce)
  moreover note IH[of Vs E X] ‹fv E2  set Vs X m [Vs [↦] lcl s] E2
    ‹length Vs + max_vars (Val aVal i:=e)  length (lcl s) ‹𝒟 E2 dom X
  ultimately show ?case by(fastforce intro: AAssRed3)
next
  case Red1AAssStore thus ?case by(auto)((rule exI conjI)+, auto)
next
  case Red1AAss thus ?case 
    by(fastforce simp del: fun_upd_apply)
next 
  case (FAss1Red1 e s ta e' s' F D e2 Vs E2 X)
  note IH = vs e2 x.  bisim vs e2 e (lcl s); fv e2  set vs;
             x m [vs [↦] lcl s]; length vs + max_vars e  length (lcl s); 𝒟 e2 dom x
              ?concl e e' e2 s x ta s' e' vs
  from ‹False,compP1 P,t ⊢1 e,s -ta e',s' have "¬ is_val e" by auto
  with ‹bisim Vs E2 (eF{D}:=e2) (lcl s) obtain E E2'
    where E2: "E2 = EF{D}:=E2'" "e2 = compE1 Vs E2'" and "bisim Vs E e (lcl s)" 
    and sync: "¬ contains_insync E2'" by(fastforce)
  with IH[of Vs E X] ‹fv E2  set Vs X m [Vs [↦] lcl s]
    ‹length Vs + max_vars (eF{D}:=e2)  length (lcl s) ‹𝒟 E2 dom X
  obtain TA' e2' x' where "sim_move10 P t ta e e' E (hp s) X TA' e2' (hp s') x'"
    "bisim Vs e2' e' (lcl s')" "x' m [Vs [↦] lcl s']" by(fastforce)
  with E2 ‹fv E2  set Vs sync show ?case by(cases "is_val e2'")(auto intro: FAssRed1)
next 
  case (FAss1Red2 e s ta e' s' v F D Vs E2 X)
  note IH = vs e2 x.  bisim vs e2 e (lcl s); fv e2  set vs;
             x m [vs [↦] lcl s]; length vs + max_vars e  length (lcl s); 𝒟 e2 dom x
             ?concl e e' e2 s x ta s' e' vs
  from ‹bisim Vs E2 (Val vF{D}:=e) (lcl s) obtain E
    where E2: "E2 = (Val vF{D}:=E)" and "bisim Vs E e (lcl s)" by(fastforce)
  with IH[of Vs E X] ‹fv E2  set Vs X m [Vs [↦] lcl s]
    ‹length Vs + max_vars (Val vF{D}:=e)  length (lcl s) ‹𝒟 E2 dom X
    E2 show ?case by(fastforce intro: FAssRed2)
next
  case (CAS1Red1 e s ta e' s' D F e2 e3 Vs E2 X)
  note IH = vs e2 x.  bisim vs e2 e (lcl s); fv e2  set vs;
             x m [vs [↦] lcl s]; length vs + max_vars e  length (lcl s); 𝒟 e2 dom x 
              ?concl e e' e2 s x ta s' e' vs
  from ‹False,compP1 P,t ⊢1 e,s -ta e',s' have "¬ is_val e" by auto
  with ‹bisim Vs E2 _ (lcl s) obtain E E2' E2''
    where E2: "E2 = E∙compareAndSwap(DF, E2', E2'')" "e2 = compE1 Vs E2'" "e3 = compE1 Vs E2''" and "bisim Vs E e (lcl s)"
    and sync: "¬ contains_insync E2'" "¬ contains_insync E2''" by(fastforce)
  moreover note IH[of Vs E X] ‹fv E2  set Vs X m [Vs [↦] lcl s]
    ‹length Vs + max_vars _  length (lcl s) ‹𝒟 E2 dom X
  ultimately obtain TA' e2' x' where IH': "sim_move10 P t ta e e' E (hp s) X TA' e2' (hp s') x'"
    "bisim Vs e2' e' (lcl s')" "x' m [Vs [↦] lcl s']" by(auto)
  show ?case
  proof(cases "is_val e2'")
    case True
    from E2 ‹fv E2  set Vs sync have "bisim Vs E2' e2 (lcl s')" "bisim Vs E2'' e3 (lcl s')" by auto
    with IH' E2 True sync show ?thesis by(cases "is_val E2'")(fastforce)+
  next
    case False with IH' E2 sync show ?thesis by(fastforce)
  qed
next
  case (CAS1Red2 e s ta e' s' v D F e3 Vs E2 X)
  note IH = vs e2 x.  bisim vs e2 e (lcl s); fv e2  set vs;
             x m [vs [↦] lcl s]; length vs + max_vars e  length (lcl s); 𝒟 e2 dom x
             ?concl e e' e2 s x ta s' e' vs
  from ‹False,compP1 P,t ⊢1 e,s -ta e',s' have "¬ is_val e" by auto
  with ‹bisim Vs E2 _ (lcl s) obtain E E2'
    where E2: "E2 = (Val v∙compareAndSwap(DF, E, E2'))" "e3 = compE1 Vs E2'" and "bisim Vs E e (lcl s)"
    and sync: "¬ contains_insync E2'" by(auto)
  moreover note IH[of Vs E X] ‹fv E2  set Vs X m [Vs [↦] lcl s]
    ‹length Vs + max_vars _  length (lcl s) ‹𝒟 E2 dom X
  ultimately obtain TA' e2' x' where "sim_move10 P t ta e e' E (hp s) X TA' e2' (hp s') x'"
    "bisim Vs e2' e' (lcl s')" "x' m [Vs [↦] lcl s']" by(auto)
  with E2 ‹fv E2  set Vs sync show ?case
    by(cases "is_val e2'")(fastforce)+
next
  case (CAS1Red3 e s ta e' s' v D F v' Vs E2 X)
  note IH = vs e2 x.  bisim vs e2 e (lcl s); fv e2  set vs;
             x m [vs [↦] lcl s]; length vs + max_vars e  length (lcl s); 𝒟 e2 dom x
             ?concl e e' e2 s x ta s' e' vs
  from ‹bisim Vs E2 _ (lcl s) obtain E
    where E2: "E2 = (Val v∙compareAndSwap(DF, Val v', E))" and "bisim Vs E e (lcl s)" by(fastforce)
  moreover note IH[of Vs E X] ‹fv E2  set Vs X m [Vs [↦] lcl s] E2
    ‹length Vs + max_vars _  length (lcl s) ‹𝒟 E2 dom X
  ultimately show ?case by(fastforce)
next
  case (Call1Obj e s ta e' s' M es Vs E2 X)
  note IH = vs e2 x.  bisim vs e2 e (lcl s); fv e2  set vs;
            x m [vs [↦] lcl s]; length vs + max_vars e  length (lcl s);
            𝒟 e2 dom x   ?concl e e' e2 s x ta s' e' vs 
  from ‹False,compP1 P,t ⊢1 e,s -ta e',s' ‹bisim Vs E2 (eM(es)) (lcl s)
  obtain E es' where E2: "E2 = EM(es')" "es = compEs1 Vs es'" and "bisim Vs E e (lcl s)"
    and sync: "¬ contains_insyncs es'" by(auto elim!: bisim_cases simp add: compEs1_conv_map)
  with IH[of Vs E X] ‹fv E2  set Vs X m [Vs [↦] lcl s]
    ‹length Vs + max_vars (eM(es))  length (lcl s) ‹𝒟 E2 dom X
  obtain TA' e2' x' where IH': "sim_move10 P t ta e e' E (hp s) X TA' e2' (hp s') x'"
    "bisim Vs e2' e' (lcl s')" "x' m [Vs [↦] lcl s']" by(fastforce)
  with E2 ‹fv E2  set Vs E2 = EM(es') sync show ?case
    by(cases "is_val e2'")(auto intro: CallObj)
next
  case (Call1Params es s ta es' s' v M Vs E2 X)
  note IH = vs es2 x.  bisims vs es2 es (lcl s); fvs es2  set vs;
            x m [vs [↦] lcl s]; length vs + max_varss es  length (lcl s); 𝒟s es2 dom x 
            ?concls es es' es2 s x ta s' es' vs
  from ‹bisim Vs E2 (Val vM(es)) (lcl s) obtain Es
    where "E2 = Val v M(Es)" "bisims Vs Es es (lcl s)" by(auto)
  with IH[of Vs Es X] ‹fv E2  set Vs X m [Vs [↦] lcl s]
    ‹length Vs + max_vars (Val vM(es))  length (lcl s) ‹𝒟 E2 dom X
    E2 = Val v M(Es) show ?case by(fastforce intro: CallParams)
next
  case (Red1CallExternal s a T M Ts Tr D vs ta va h' e' s' Vs E2 X)
  from ‹bisim Vs E2 (addr aM(map Val vs)) (lcl s) have E2: "E2 = addr aM(map Val vs)" by auto
  moreover from ‹compP1 P  class_type_of T sees M: TsTr = Native in D
  have "P  class_type_of T sees M: TsTr = Native in D" by simp
  moreover from ‹compP1 P,t  aM(vs),hp s -ta→ext va,h'
  have "P,t  aM(vs),hp s -ta→ext va,h'" by simp
  moreover from wf P,t  aM(vs),hp s -ta→ext va,h'
  have "ta_bisim01 (extTA2J0 P ta) (extTA2J1 (compP1 P) ta)"
    by(rule red_external_ta_bisim01)
  moreover note typeof_addr (hp s) a = T e' = extRet2J1 (addr aM(map Val vs)) va s' = (h', lcl s)
  moreover from typeof_addr (hp s) a = T P,t  aM(vs),hp s -ta→ext va,h'
    P  class_type_of T sees M: TsTr = Native in D
  have "τexternal_defs D M  ta = ε  h' = hp s"
    by(fastforce dest: τexternal'_red_external_heap_unchanged τexternal'_red_external_TA_empty simp add: τexternal'_def τexternal_def)
  ultimately show ?case using X m [Vs [↦] lcl s]
    by(fastforce intro!: exI[where x="extTA2J0 P ta"] intro: RedCallExternal simp add: map_eq_append_conv sim_move10_def synthesized_call_def dest: sees_method_fun del: disjCI intro: disjI1 disjI2)
next
  case (Block1Red e h x ta e' h' x' V T Vs E2 X)
  note IH = vs e2 xa.  bisim vs e2 e (lcl (h, x)); fv e2  set vs; xa m [vs [↦] lcl (h, x)];
                       length vs + max_vars e  length (lcl (h, x)); 𝒟 e2 dom xa
              ?concl e e' e2 (h, x) xa ta (h', x') e' vs 
  from ‹False,compP1 P,t ⊢1 e,(h, x) -ta e',(h', x')
  have "length x = length x'" by(auto dest: red1_preserves_len)
  with ‹length Vs + max_vars {V:T=None; e}  length (lcl (h, x))
  have "length Vs < length x'" by simp
  from ‹bisim Vs E2 {V:T=None; e} (lcl (h, x))
  show ?case
  proof(cases rule: bisim_cases(14)[consumes 1, case_names BlockNone BlockSome BlockSomeNone])
    case (BlockNone V' E)
    with ‹fv E2  set Vs have "fv E  set (Vs@[V'])" by auto
    with IH[of "Vs@[V']" E "X(V' := None)"] BlockNone ‹fv E2  set Vs X m [Vs [↦] lcl (h, x)]
      ‹length Vs + max_vars {V:T=None; e}  length (lcl (h, x)) ‹𝒟 E2 dom X
    obtain TA' e2' X' where IH': "sim_move10 P t ta e e' E h (X(V' := None)) TA' e2' h' X'"
      "bisim (Vs @ [V']) e2' e' x'" "X' m [Vs @ [V'] [↦] x']"
      by(fastforce simp del: fun_upd_apply)
    { assume "V'  set Vs"
      hence "hidden (Vs @ [V']) (index Vs V')" by(rule hidden_index)
      with ‹bisim (Vs @ [V']) E e (lcl (h, x)) have "unmod e (index Vs V')"
        by(auto intro: hidden_bisim_unmod)
      moreover from ‹length Vs + max_vars {V:T=None; e}  length (lcl (h, x)) V'  set Vs
      have "index Vs V' < length x" by(auto intro: index_less_aux)
      ultimately have "x ! index Vs V' = x' ! index Vs V'"
        using red1_preserves_unmod[OF ‹False,compP1 P,t ⊢1 e,(h, x) -ta e',(h', x')]
        by(simp) }
    with ‹length Vs + max_vars {V:T=None; e}  length (lcl (h, x)) 
      X' m [Vs @ [V'] [↦] x'] ‹length x = length x' X m [Vs [↦] lcl (h, x)]
    have rel: "X'(V' := X V') m [Vs [↦] x']" by(auto intro: Block_lem)

    show ?thesis
    proof(cases "X' V'")
      case None
      with BlockNone IH' rel show ?thesis by(fastforce intro: BlockRed)
    next
      case (Some v)
      with X' m [Vs @ [V'] [↦] x'] ‹length Vs < length x'
      have "x' ! length Vs = v" by(auto dest: map_le_SomeD)
      with BlockNone IH' rel Some show ?thesis by(fastforce intro: BlockRed)
    qed
  next
    case BlockSome thus ?thesis by simp
  next
    case (BlockSomeNone V' E)
    with ‹fv E2  set Vs have "fv E  set (Vs@[V'])" by auto
    with IH[of "Vs@[V']" E "X(V'  x ! length Vs)"] BlockSomeNone ‹fv E2  set Vs X m [Vs [↦] lcl (h, x)]
      ‹length Vs + max_vars {V:T=None; e}  length (lcl (h, x)) ‹𝒟 E2 dom X
    obtain TA' e2' X' where IH': "sim_move10 P t ta e e' E h (X(V'  x ! length Vs)) TA' e2' h' X'"
      "bisim (Vs @ [V']) e2' e' x'" "X' m [Vs @ [V'] [↦] x']"
      by(fastforce simp del: fun_upd_apply)
    { assume "V'  set Vs"
      hence "hidden (Vs @ [V']) (index Vs V')" by(rule hidden_index)
      with ‹bisim (Vs @ [V']) E e (lcl (h, x)) have "unmod e (index Vs V')"
        by(auto intro: hidden_bisim_unmod)
      moreover from ‹length Vs + max_vars {V:T=None; e}  length (lcl (h, x)) V'  set Vs
      have "index Vs V' < length x" by(auto intro: index_less_aux)
      ultimately have "x ! index Vs V' = x' ! index Vs V'"
        using red1_preserves_unmod[OF ‹False,compP1 P,t ⊢1 e,(h, x) -ta e',(h', x')]
        by(simp) }
    with ‹length Vs + max_vars {V:T=None; e}  length (lcl (h, x)) 
      X' m [Vs @ [V'] [↦] x'] ‹length x = length x' X m [Vs [↦] lcl (h, x)]
    have rel: "X'(V' := X V') m [Vs [↦] x']" by(auto intro: Block_lem)
    from ‹sim_move10 P t ta e e' E h (X(V'  x ! length Vs)) TA' e2' h' X'
    obtain v' where "X' V' = v'"
      by(auto simp: sim_move10_def split: if_split_asm dest!: τred0t_lcl_incr τred0r_lcl_incr red_lcl_incr subsetD)
    with X' m [Vs @ [V'] [↦] x'] ‹length Vs < length x'
    have "x' ! length Vs = v'" by(auto dest: map_le_SomeD)
    with BlockSomeNone IH' rel X' V' = v'
    show ?thesis by(fastforce intro: BlockRed)
  qed
next
  case(Block1Some V xs T v e h)
  from ‹bisim vs e2 {V:T=v; e} (lcl (h, xs)) obtain e' V' where "e2 = {V':T=v; e'}"
    and "V = length vs" "bisim (vs @ [V']) e' e (xs[length vs := v])" by(fastforce)
  moreover have "sim_move10 P t ε {length vs:T=v; e} {length vs:T=None; e} {V':T=v; e'} h x ε {V':T=v; e'} h x"
    by(auto)
  moreover from ‹bisim (vs @ [V']) e' e (xs[length vs := v])
    ‹length vs + max_vars {V:T=v; e}  length (lcl (h, xs))
  have "bisim vs {V':T=v; e'} {length vs:T=None; e} (xs[length vs := v])" by auto
  moreover from x m [vs [↦] lcl (h, xs)] ‹length vs + max_vars {V:T=v; e}  length (lcl (h, xs))
  have "x m [vs [↦] xs[length vs := v]]" by auto
  ultimately show ?case by auto
next
  case (Lock1Synchronized V xs a e h Vs E2 X)
  note len = ‹length Vs + max_vars (syncV (addr a) e)  length (lcl (h, xs))
  from ‹bisim Vs E2 (syncV (addr a) e) (lcl (h, xs)) obtain E
    where E2: "E2 = sync(addr a) E" "e = compE1 (Vs@[fresh_var Vs]) E" 
    and sync: "¬ contains_insync E" and [simp]: "V = length Vs" by auto
  moreover
  have "extTA2J0 P,P,t  sync(addr a) E, (h, X) -Locka, SyncLock a insync(a) E, (h, X)"
    by(rule LockSynchronized)
  moreover from ‹fv E2  set Vs fresh_var_fresh[of Vs] sync len
  have "bisim Vs (insync(a) E) (insynclength Vs (a) e) (xs[length Vs := Addr a])"
    unfolding e = compE1 (Vs@[fresh_var Vs]) E E2 = sync(addr a) E
    by -(rule bisimInSynchronized,rule compE1_bisim, auto)
  moreover have "zip Vs (xs[length Vs := Addr a]) = (zip Vs xs)[length Vs := (arbitrary, Addr a)]"
    by(rule sym)(simp add: update_zip)
  hence "zip Vs (xs[length Vs := Addr a]) = zip Vs xs" by simp
  with X m [Vs [↦] (lcl (h, xs))] have "X m [Vs [↦] xs[length Vs := Addr a]]"
    by(auto simp add: map_le_def map_upds_def)
  ultimately show ?case by(fastforce intro: sim_move10_SyncLocks)
next
  case (Synchronized1Red2 e s ta e' s' V a Vs E2 X)
  note IH = vs e2 x.  bisim vs e2 e (lcl s); fv e2  set vs;
            x m [vs [↦] lcl s]; length vs + max_vars e  length (lcl s);
            𝒟 e2 dom x   ?concl e e' e2 s x ta s' e' vs 
  from ‹bisim Vs E2 (insyncV (a) e) (lcl s) obtain E
    where E2: "E2 = insync(a) E" and bisim: "bisim (Vs@[fresh_var Vs]) E e (lcl s)"
    and xsa: "lcl s ! length Vs = Addr a" and [simp]: "V = length Vs" by auto
  with ‹fv E2  set Vs fresh_var_fresh[of Vs] have fv: "(fresh_var Vs)  fv E" by auto
  from ‹length Vs + max_vars (insyncV (a) e)  length (lcl s) have "length Vs < length (lcl s)" by simp
  { assume "X (fresh_var Vs)  None"
    then obtain v where "X (fresh_var Vs) = v" by auto
    with X m [Vs [↦] lcl s] have "[Vs [↦] lcl s] (fresh_var Vs) = v" 
      by(auto simp add: map_le_def dest: bspec)
    hence "(fresh_var Vs)  set Vs" 
      by(auto simp add: map_upds_def set_zip dest!: map_of_SomeD )
    moreover have "(fresh_var Vs)  set Vs" by(rule fresh_var_fresh)
    ultimately have False by contradiction }
  hence "X (fresh_var Vs) = None" by(cases "X (fresh_var Vs)", auto)
  hence "X(fresh_var Vs := None) = X" by(auto intro: ext)
  moreover from X m [Vs [↦] lcl s]
  have "X(fresh_var Vs := None) m [Vs [↦] lcl s, (fresh_var Vs)  (lcl s) ! length Vs]" by(simp)
  ultimately have "X m [Vs @ [fresh_var Vs] [↦] lcl s]"
    using ‹length Vs < length (lcl s) by(auto)
  moreover note IH[of "Vs@[fresh_var Vs]" E X] bisim E2 ‹fv E2  set Vs X m [Vs [↦] lcl s] 
    ‹length Vs + max_vars (insyncV (a) e)  length (lcl s) ‹𝒟 E2 dom X
  ultimately obtain TA' e2' x' where IH': "sim_move10 P t ta e e' E (hp s) X TA' e2' (hp s') x'"
    "bisim (Vs @ [fresh_var Vs]) e2' e' (lcl s')" "x' m [Vs @ [fresh_var Vs] [↦] lcl s']" by auto
  hence "dom x'  dom X  fv E"
    by(fastforce iff del: domIff simp add: sim_move10_def dest: red_dom_lcl τred0r_dom_lcl[OF wf_prog_wwf_prog[OF wf]] τred0t_dom_lcl[OF wf_prog_wwf_prog[OF wf]] τred0r_fv_subset[OF wf_prog_wwf_prog[OF wf]] split: if_split_asm)
  with fv X (fresh_var Vs) = None› have "(fresh_var Vs)  dom x'" by auto
  hence "x' (fresh_var Vs) = None" by auto
  moreover from ‹False,compP1 P,t ⊢1 e,s -ta e',s'
  have "length (lcl s) = length (lcl s')" by(auto dest: red1_preserves_len)
  moreover note x' m [Vs @ [fresh_var Vs] [↦] lcl s'] ‹length Vs < length (lcl s)
  ultimately have "x' m [Vs [↦] lcl s']" by(auto simp add: map_le_def dest: bspec)
  moreover from bisim fv have "unmod e (length Vs)" by(auto intro: bisim_fv_unmod)
  with ‹False,compP1 P,t ⊢1 e,s -ta e',s' ‹length Vs < length (lcl s)
  have "lcl s ! length Vs = lcl s' ! length Vs"
    by(auto dest!: red1_preserves_unmod)
  with xsa have "lcl s' ! length Vs = Addr a" by simp
  ultimately show ?case using IH' E2 by(auto intro: SynchronizedRed2)
next
  case (Unlock1Synchronized xs V a' a v h Vs E2 X)
  from ‹bisim Vs E2 (insyncV (a) Val v) (lcl (h, xs))
  have E2: "E2 = insync(a) Val v" "V = length Vs" "xs ! length Vs = Addr a" by auto
  moreover with xs ! V = Addr a' have [simp]: "a' = a" by simp
  have "extTA2J0 P,P,t  insync(a) (Val v), (h, X) -Unlocka, SyncUnlock a Val v, (h, X)"
    by(rule UnlockSynchronized)
  ultimately show ?case using X m [Vs [↦] lcl (h, xs)] by(fastforce intro: sim_move10_SyncLocks)
next
  case (Unlock1SynchronizedNull xs V a v h Vs E2 X)
  from ‹bisim Vs E2 (insyncV (a) Val v) (lcl (h, xs))
  have "V = length Vs" "xs ! length Vs = Addr a" by(auto)
  with xs ! V = Null› have False by simp
  thus ?case ..
next
  case (Unlock1SynchronizedFail xs V A' a' v h Vs E2 X)
  from ‹False› show ?case ..
next
  case (Red1While b c s Vs E2 X)
  from ‹bisim Vs E2 (while (b) c) (lcl s) obtain B C
    where E2: "E2 = while (B) C" "b = compE1 Vs B" "c = compE1 Vs C" 
    and sync: "¬ contains_insync B" "¬ contains_insync C" by auto
  moreover have "extTA2J0 P,P,t  while (B) C, (hp s, X) -ε if (B) (C;;while (B) C) else unit, (hp s, X)"
    by(rule RedWhile)
  hence "sim_move10 P t ε (while (compE1 Vs B) (compE1 Vs C)) (if (compE1 Vs B) (compE1 Vs C;;while (compE1 Vs B) (compE1 Vs C)) else unit) (while (B) C) (hp s) X ε (if (B) (C;;while (B) C) else unit) (hp s) X"
    by(auto simp add: sim_move10_def)
  moreover from ‹fv E2  set Vs E2 sync
  have "bisim Vs (if (B) (C;; while (B) C) else unit)
                 (if (compE1 Vs B) (compE1 Vs (C;; while(B) C)) else (compE1 Vs unit)) (lcl s)"
    by -(rule bisimCond, auto)
  ultimately show ?case using X m [Vs [↦] lcl s]
    by(simp)(rule exI, rule exI, rule exI, erule conjI, auto)
next
  case (Red1TryCatch h a D C V x e2 Vs E2 X)
  from ‹bisim Vs E2 (try Throw a catch(C V) e2) (lcl (h, x))
  obtain E2' V' where "E2 = try Throw a catch(C V') E2'" "V = length Vs" "e2 = compE1 (Vs @ [V']) E2'"
    and sync: "¬ contains_insync E2'" by(auto)
  with ‹fv E2  set Vs have "fv E2'  set (Vs @[V'])" by auto
  with e2 = compE1 (Vs @ [V']) E2'  sync have "bisim (Vs @[V']) E2' e2 (x[V := Addr a])"
    by(auto intro!: compE1_bisim)
  with V = length Vs ‹length Vs + max_vars (try Throw a catch(C V) e2)  length (lcl (h, x))
  have "bisim Vs {V':Class C=Addr a; E2'} {length Vs:Class C=None; e2} (x[V := Addr a])"
    by(auto intro: bisimBlockSomeNone)
  moreover from ‹length Vs + max_vars (try Throw a catch(C V) e2)  length (lcl (h, x))
  have "[Vs [↦] x[length Vs := Addr a]] = [Vs [↦] x]" by simp
  with X m [Vs [↦] lcl (h, x)] have "X m [Vs [↦] x[length Vs := Addr a]]" by simp
  moreover note e2 = compE1 (Vs @ [V']) E2' E2 = try Throw a catch(C V') E2'
    typeof_addr h a = Class_type D ‹compP1 P  D * C V = length Vs
  ultimately show ?case by(auto intro!: exI)
next
  case Red1TryFail thus ?case by(auto intro!: exI sim_move10_TryFail)
next
  case (List1Red1 e s ta e' s' es Vs ES2 X)
  note IH = vs e2 x.  bisim vs e2 e (lcl s); fv e2  set vs;
            x m [vs [↦] lcl s]; length vs + max_vars e  length (lcl s); 𝒟 e2 dom x
            TA' e2' x'. sim_move10 P t ta e e' e2 (hp s) x TA' e2' (hp s') x'  
                 bisim vs e2' e' (lcl s')  x' m [vs [↦] lcl s']
  from ‹bisims Vs ES2 (e # es) (lcl s) ‹False,compP1 P,t ⊢1 e,s -ta e',s'
  obtain E ES where "ES2 = E # ES" "¬ is_val E" "es = compEs1 Vs ES" "bisim Vs E e (lcl s)"
    and sync: "¬ contains_insyncs ES" by(auto elim!: bisims_cases simp add: compEs1_conv_map)
  with IH[of Vs E X] ‹fvs ES2  set Vs X m [Vs [↦] lcl s]
    ‹length Vs + max_varss (e # es)  length (lcl s) ‹𝒟s ES2 dom X
  obtain TA' e2' x' where IH': "sim_move10 P t ta e e' E (hp s) X TA' e2' (hp s') x'"
    "bisim Vs e2' e' (lcl s')" "x' m [Vs [↦] lcl s']" by fastforce
  show ?case
  proof(cases "is_val e2'")
    case False
    with IH' ES2 = E # ES es = compEs1 Vs ES sync show ?thesis by(auto intro: sim_moves10_expr)
  next
    case True
    from ‹fvs ES2  set Vs ES2 = E # ES es = compEs1 Vs ES sync
    have "bisims Vs ES es (lcl s')" by(auto intro: compEs1_bisims)
    with IH' True ES2 = E # ES es = compEs1 Vs ES show ?thesis by(auto intro: sim_moves10_expr)
  qed
next
  case (List1Red2 es s ta es' s' v Vs ES2 X)
  note IH = vs es2 x. bisims vs es2 es (lcl s); fvs es2  set vs;
            x m [vs [↦] lcl s]; length vs + max_varss es  length (lcl s); 𝒟s es2 dom x
            TA' es2' x'. sim_moves10 P t ta es es' es2 (hp s) x TA' es2' (hp s') x'  bisims vs es2' es' (lcl s')  x' m [vs [↦] lcl s']
  from ‹bisims Vs ES2 (Val v # es) (lcl s) obtain ES where "ES2 = Val v # ES" "bisims Vs ES es (lcl s)"
    by(auto elim!: bisims_cases)
  with IH[of Vs ES X] ‹fvs ES2  set Vs X m [Vs [↦] lcl s]
    ‹length Vs + max_varss (Val v # es)  length (lcl s) ‹𝒟s ES2 dom X
    ES2 = Val v # ES show ?case by(fastforce intro: sim_moves10_expr)
next
  case Call1ThrowParams
  thus ?case by(fastforce intro: CallThrowParams elim!: bisim_cases simp add: bisims_map_Val_Throw2)
next
  case (Synchronized1Throw2 xs V a' a ad h Vs E2 X)
  from ‹bisim Vs E2 (insyncV (a) Throw ad) (lcl (h, xs))
  have "xs ! length Vs = Addr a" and "V = length Vs" by auto
  with xs ! V = Addr a' have [simp]: "a' = a" by simp
  have "extTA2J0 P,P,t  insync(a) Throw ad, (h, X) -Unlocka, SyncUnlock a Throw ad, (h, X)"
    by(rule SynchronizedThrow2)
  with X m [Vs [↦] lcl (h, xs)] ‹bisim Vs E2 (insyncV (a) Throw ad) (lcl (h, xs))
  show ?case by(auto intro: sim_move10_SyncLocks intro!: exI)
next
  case (Synchronized1Throw2Null xs V a a' h Vs E2 X)
  from ‹bisim Vs E2 (insyncV (a) Throw a') (lcl (h, xs))
  have "V = length Vs" "xs ! length Vs = Addr a" by(auto)
  with xs ! V = Null› have False by simp
  thus ?case ..
next
  case (Synchronized1Throw2Fail xs V A' a' a h Vs E2 X)
  from ‹False› show ?case ..
next
  case InstanceOf1Red thus ?case by auto(blast)
next
  case Red1InstanceOf thus ?case by hypsubst_thin auto
next
  case InstanceOf1Throw thus ?case by auto
next
  case CAS1Throw thus ?case by fastforce
next
  case CAS1Throw2 thus ?case by fastforce
next
  case CAS1Throw3 thus ?case by fastforce
qed(simp_all del: fun_upd_apply, (fastforce intro: red_reds.intros simp del: fun_upd_apply simp add: finfun_upd_apply)+)

lemma bisim_call_Some_call1:
  " bisim Vs e e' xs; call e = aMvs; length Vs + max_vars e'  length xs 
   e'' xs'. τred1'r P t h (e', xs) (e'', xs')  call1 e'' = aMvs  
               bisim Vs e e'' xs'  take (length Vs) xs = take (length Vs) xs'"

  and bisims_calls_Some_calls1:
  " bisims Vs es es' xs; calls es = aMvs; length Vs + max_varss es'  length xs  
   es'' xs'. τreds1'r P t h (es', xs) (es'', xs')  calls1 es'' = aMvs  
                bisims Vs es es'' xs'  take (length Vs) xs = take (length Vs) xs'"
proof(induct rule: bisim_bisims.inducts)
  case bisimCallParams thus ?case
    by(fastforce simp add: is_vals_conv split: if_split_asm)
next
  case bisimBlockNone thus ?case by(fastforce intro: take_eq_take_le_eq)
next
  case (bisimBlockSome Vs V e e' xs v T)
  from ‹length Vs + max_vars {length Vs:T=v; e'}  length xs
  have "τred1'r P t h ({length Vs:T=v; e'}, xs) ({length Vs:T=None; e'}, xs[length Vs := v])"
    by(auto intro!: τred1r_1step Block1Some)
  also from bisimBlockSome obtain e'' xs'
    where "τred1'r P t h (e', xs[length Vs := v]) (e'', xs')"
    and "call1 e'' = aMvs" "bisim (Vs @ [V]) e e'' xs'" 
    and "take (length (Vs @ [V])) (xs[length Vs := v]) = take (length (Vs @ [V])) xs'" by auto
  hence "τred1'r P t h ({length Vs:T=None; e'}, xs[length Vs := v]) ({length Vs:T=None; e''}, xs')" by auto
  also from ‹call1 e'' = aMvs have "call1 {length Vs:T=None; e''} = aMvs" by simp
  moreover from ‹take (length (Vs @ [V])) (xs[length Vs := v]) = take (length (Vs @ [V])) xs'
  have "take (length Vs) xs = take (length Vs) xs'"
    by(auto dest: take_eq_take_le_eq[where m="length Vs"] simp add: take_list_update_beyond)
  moreover {
    have "xs' ! length Vs = take (length (Vs @ [V])) xs' ! length Vs" by simp
    also note ‹take (length (Vs @ [V])) (xs[length Vs := v]) = take (length (Vs @ [V])) xs'[symmetric]
    also have "take (length (Vs @ [V])) (xs[length Vs := v]) ! length Vs = v"
      using ‹length Vs + max_vars {length Vs:T=v; e'}  length xs by simp
    finally have "bisim Vs {V:T=v; e} {length Vs:T=None; e''} xs'"
      using ‹bisim (Vs @ [V]) e e'' xs' by auto }
  ultimately show ?case by blast
next
  case (bisimBlockSomeNone Vs V e e' xs v T)
  then obtain e'' xs' where "τred1'r P t h (e', xs) (e'', xs')" "call1 e'' = aMvs" "bisim (Vs @ [V]) e e'' xs'"
    and "take (length (Vs @ [V])) xs = take (length (Vs @ [V])) xs'" by auto
  hence "τred1'r P t h ({length Vs:T=None; e'}, xs) ({length Vs:T=None; e''}, xs')" by auto
  moreover from ‹call1 e'' = aMvs have "call1 ({length Vs:T=None; e''}) = aMvs" by simp
  moreover from ‹take (length (Vs @ [V])) xs = take (length (Vs @ [V])) xs'
  have "take (length Vs) xs = take (length Vs) xs'" by(auto intro: take_eq_take_le_eq)
  moreover {
    have "xs' ! length Vs = take (length (Vs @ [V])) xs' ! length Vs" by simp
    also note ‹take (length (Vs @ [V])) xs = take (length (Vs @ [V])) xs'[symmetric]
    also have "take (length (Vs @ [V])) xs ! length Vs = v" using xs ! length Vs = v by simp
    finally have "bisim Vs {V:T=v; e} {length Vs:T=None; e''} xs'"
      using ‹bisim (Vs @ [V]) e e'' xs' by auto }
  ultimately show ?case by blast
next
  case (bisimInSynchronized Vs e e' xs a)
  then obtain e'' xs' where "τred1'r P t h (e', xs) (e'', xs')" "call1 e'' = aMvs" "bisim (Vs @ [fresh_var Vs]) e e'' xs'"
    and "take (Suc (length Vs)) xs = take (Suc (length Vs)) xs'" by auto
  hence "τred1'r P t h (insynclength Vs (a) e', xs) (insynclength Vs (a) e'', xs')" by auto
  moreover from ‹call1 e'' = aMvs have "call1 (insynclength Vs (a) e'') = aMvs" by simp
  moreover from ‹take (Suc (length Vs)) xs = take (Suc (length Vs)) xs'
  have "take (length Vs) xs = take (length Vs) xs'" by(auto intro: take_eq_take_le_eq)
  moreover {
    have "xs' ! length Vs = take (Suc (length Vs)) xs' ! length Vs" by simp
    also note ‹take (Suc (length Vs)) xs = take (Suc (length Vs)) xs'[symmetric]
    also have "take (Suc (length Vs)) xs ! length Vs = Addr a"
      using xs ! length Vs = Addr a by simp
    finally have "bisim Vs (insync(a) e) (insynclength Vs (a) e'') xs'"
      using ‹bisim (Vs @ [fresh_var Vs]) e e'' xs' by auto }
  ultimately show ?case by blast
next
  case bisimsCons1 thus ?case by(fastforce intro!: τred1r_inj_τreds1r)
next
  case bisimsCons2 thus ?case by(fastforce intro!: τreds1r_cons_τreds1r)
qed fastforce+

lemma sim_move01_into_Red1:
  "sim_move01 P t ta e E' h xs ta' e2' h' xs'
   if τMove0 P h (e, es1)
      then τRed1't P t h ((E', xs), exs2) ((e2', xs'), exs2)  ta = ε  h = h'
      else ex2' exs2' ta'. τRed1'r P t h ((E', xs), exs2) (ex2', exs2') 
                           (call e = None  call1 E' = None  ex2' = (E', xs)  exs2' = exs2) 
                           False,P,t ⊢1 ex2'/exs2',h -ta' (e2', xs')/exs2,h' 
                           ¬ τMove1 P h (ex2', exs2')  ta_bisim01 ta ta'"
apply(auto simp add: sim_move01_def intro: τred1t_into_τRed1t τred1r_into_τRed1r red1Red split: if_split_asm)
apply(fastforce intro: red1Red intro!: τred1r_into_τRed1r)+
done

lemma sim_move01_max_vars_decr:
  "sim_move01 P t ta e0 e h xs ta' e' h' xs'  max_vars e'  max_vars e"
by(fastforce simp add: sim_move01_def split: if_split_asm dest: τred1t_max_vars red1_max_vars_decr τred1r_max_vars)

lemma Red1_simulates_red0:
  assumes wf: "wf_J_prog P"
  and red: "P,t ⊢0 e1/es1, h -ta e1'/es1', h'"
  and bisiml: "bisim_list1 (e1, es1) (ex2, exs2)"
  shows "ex2'' exs2''. bisim_list1 (e1', es1') (ex2'', exs2'') 
        (if τMove0 P h (e1, es1)
         then τRed1't (compP1 P) t h (ex2, exs2) (ex2'', exs2'')  ta = ε  h = h'
         else ex2' exs2' ta'. τRed1'r (compP1 P) t h (ex2, exs2) (ex2', exs2')  
                               (call e1 = None  call1 (fst ex2) = None  ex2' = ex2  exs2' = exs2) 
                               False,compP1 P,t ⊢1 ex2'/exs2', h -ta' ex2''/exs2'', h' 
                               ¬ τMove1 P h (ex2', exs2')  ta_bisim01 ta ta')"
  (is "ex2'' exs2'' . _  ?red ex2'' exs2''")
using red
proof(cases)
  case (red0Red XS')
  note [simp] = es1' = es1
    and red = ‹extTA2J0 P,P,t  e1,(h, Map.empty) -ta e1',(h', XS')
    and notsynth = aMvs. call e1 = aMvs  synthesized_call P h aMvs
  from bisiml obtain E xs where ex2: "ex2 = (E, xs)"
    and bisim: "bisim [] e1 E xs" and fv: "fv e1 = {}" 
    and length: "max_vars E  length xs" and bsl: "bisim_list es1 exs2"
    and D: "𝒟 e1 {}" by(auto elim!: bisim_list1_elim)
  from bisim_max_vars[OF bisim] length red1_simulates_red_aux[OF wf red bisim] fv notsynth
  obtain ta' e2' xs' where sim: "sim_move01 (compP1 P) t ta e1 E h xs ta' e2' h' xs'"
    and bisim': "bisim [] e1' e2' xs'" and XS': "XS' m Map.empty" by auto
  from sim_move01_into_Red1[OF sim, of es1 exs2]
  have "?red (e2', xs') exs2" unfolding ex2 by auto
  moreover {
    note bsl bisim' moreover
    from fv red_fv_subset[OF wf_prog_wwf_prog[OF wf] red]
    have "fv e1' = {}" by simp
    moreover from red D have "𝒟 e1' dom XS'"
      by(auto dest: red_preserves_defass[OF wf] split: if_split_asm)
    with red_dom_lcl[OF red] ‹fv e1 = {} have "𝒟 e1' {}"
      by(auto elim!: D_mono' simp add: hyperset_defs)
    moreover from sim have "length xs = length xs'" "max_vars e2'  max_vars E"
      by(auto dest: sim_move01_preserves_len sim_move01_max_vars_decr)
    with length have length': "max_vars e2'  length xs'" by(auto)
    ultimately have "bisim_list1 (e1', es1) ((e2', xs'), exs2)" by(rule bisim_list1I) }
  ultimately show ?thesis using ex2 by(simp split del: if_split)(rule exI conjI|assumption)+
next
  case (red0Call a M vs U Ts T pns body D)
  note [simp] = ta = ε h' = h
    and es1' = es1' = e1 # es1
    and e1' = e1' = blocks (this # pns) (Class D # Ts) (Addr a # vs) body
    and call = ‹call e1 = (a, M, vs)
    and ha = typeof_addr h a = U
    and sees = P  class_type_of U sees M: TsT = (pns, body) in D
    and len = ‹length vs = length pns ‹length Ts = length pns
  from bisiml obtain E xs where ex2: "ex2 = (E, xs)"
    and bisim: "bisim [] e1 E xs" and fv: "fv e1 = {}" 
    and length: "max_vars E  length xs" and bsl: "bisim_list es1 exs2"
    and D: "𝒟 e1 {}" by(auto elim!: bisim_list1_elim)
  
  from bisim_call_Some_call1[OF bisim call, of "compP1 P" t h] length
  obtain e' xs' where red: "τred1'r (compP1 P) t h (E, xs) (e', xs')"
    and "call1 e' = (a, M, vs)" "bisim [] e1 e' xs'" 
    and "take 0 xs = take 0 xs'" by auto
    
  let ?e1' = "blocks (this # pns) (Class D # Ts) (Addr a # vs) body"
  let ?e2' = "blocks1 0 (Class D#Ts) (compE1 (this # pns) body)"
  let ?xs2' = "Addr a # vs @ replicate (max_vars (compE1 (this # pns) body)) undefined_value"
  let ?exs2' = "(e', xs') # exs2"

  have "τRed1'r (compP1 P) t h ((E, xs), exs2) ((e', xs'), exs2)"
    using red by(rule τred1r_into_τRed1r)
  moreover {
    note ‹call1 e' = (a, M, vs) 
    moreover note ha
    moreover have "compP1 P  class_type_of U sees M:Ts  T = map_option (λ(pns, body). compE1 (this # pns) body) (pns, body) in D"
      using sees unfolding compP1_def by(rule sees_method_compP)
    hence sees': "compP1 P  class_type_of U sees M:Ts  T = compE1 (this # pns) body in D" by simp
    moreover from len have "length vs = length Ts" by simp
    ultimately have "False,compP1 P,t ⊢1 (e', xs')/exs2,h -ε (?e2', ?xs2')/?exs2', h" by(rule red1Call) 
    moreover have "τMove1 P h ((e', xs'), exs2)" using ‹call1 e' = (a, M, vs) ha sees
      by(auto simp add: synthesized_call_def τexternal'_def dest: sees_method_fun dest!: τmove1_not_call1[where P=P and h=h])
    ultimately have "τRed1' (compP1 P) t h ((e', xs'), exs2) ((?e2', ?xs2'), ?exs2')" by auto }
  ultimately have "τRed1't (compP1 P) t h ((E, xs), exs2) ((?e2', ?xs2'), ?exs2')" by(rule rtranclp_into_tranclp1)
  moreover
  { from red have "length xs' = length xs" by(rule τred1r_preserves_len)
    moreover from red have "max_vars e'  max_vars E" by(rule τred1r_max_vars)
    ultimately have "max_vars e'  length xs'" using length by simp }
  with bsl ‹bisim [] e1 e' xs' fv D have "bisim_list (e1 # es1) ?exs2'"
    using ‹call e1 = (a, M, vs) ‹call1 e' = (a, M, vs) by(rule bisim_listCons)
  hence "bisim_list1 (e1', es1') ((?e2', ?xs2'), ?exs2')"
    unfolding e1' es1'
  proof(rule bisim_list1I)
    from wf_prog_wwf_prog[OF wf] sees
    have "wf_mdecl wwf_J_mdecl P D (M,Ts,T,(pns,body))" by(rule sees_wf_mdecl)
    hence fv': "fv body  set pns  {this}" by(auto simp add: wf_mdecl_def)
    moreover from P  class_type_of U sees M: TsT = (pns, body) in D have "¬ contains_insync body"
      by(auto dest!: sees_wf_mdecl[OF wf] WT_expr_locks simp add: wf_mdecl_def contains_insync_conv)
    ultimately have "bisim ([this] @ pns) body (compE1 ([this] @ pns) body) ?xs2'"
      by -(rule compE1_bisim, auto)
    with ‹length vs = length pns ‹length Ts = length pns
    have "bisim ([] @ [this]) (blocks pns Ts vs body) (blocks1 (Suc 0) Ts (compE1 (this # pns) body)) ?xs2'"
      by -(drule blocks_bisim,auto simp add: nth_append)
    from bisimBlockSomeNone[OF this, of "Addr a" "Class D"]
    show "bisim [] ?e1' ?e2' ?xs2'" by simp
    from fv' len show "fv ?e1' = {}" by auto

    from wf sees
    have "wf_mdecl wf_J_mdecl P D (M,Ts,T,(pns,body))" by(rule sees_wf_mdecl)
    hence "𝒟 body set pns  {this}" by(auto simp add: wf_mdecl_def)
    with ‹length vs = length pns ‹length Ts = length pns
    have "𝒟 (blocks pns Ts vs body) dom [this  Addr a]" by(auto)
    thus "𝒟 ?e1' {}" by auto
    
    from len show "max_vars ?e2'  length ?xs2'" by(auto simp add: blocks1_max_vars)
  qed
  moreover have "τMove0 P h (e1, es1)" using call ha sees
    by(fastforce simp add: synthesized_call_def  τexternal'_def dest: sees_method_fun τmove0_callD[where P=P and h=h])
  ultimately show ?thesis using ex2 ‹call e1 = (a, M, vs) 
    by(simp del: τMove1.simps)(rule exI conjI|assumption)+
next
  case (red0Return e)
  note es1 = es1 = e # es1' and e1' = e1' = inline_call e1 e
    and [simp] = ta = ε h' = h
    and fin = ‹final e1
  from bisiml es1 obtain E' xs' E xs exs' aMvs where ex2: "ex2 = (E', xs')" and exs2: "exs2 = (E, xs) # exs'"
    and bisim': "bisim [] e1 E' xs'"
    and bisim: "bisim [] e E xs"
    and fv: "fv e = {}"
    and length: "max_vars E  length xs"
    and bisiml: "bisim_list es1' exs'"
    and D: "𝒟 e {}"
    and call: "call e = aMvs"
    and call1: "call1 E = aMvs"
    by(fastforce elim: bisim_list1_elim)
  let ?e2' = "inline_call E' E"

  from ‹final e1 bisim' have "final E'" by(auto)
  hence red': "False,compP1 P,t ⊢1 ex2/exs2, h -ε (?e2', xs)/exs', h"
    unfolding ex2 exs2 by(rule red1Return)
  moreover have "τMove0 P h (e1, es1) = τMove1 P h ((E', xs'), exs2)"
    using ‹final e1 ‹final E' by auto
  moreover {
    note bisiml
    moreover
    from bisim' fin bisim
    have "bisim [] (inline_call e1 e) (inline_call E' E) xs"
      using call by(rule bisim_inline_call)(simp add: fv)
    moreover from fv_inline_call[of e1 e] fv fin 
    have "fv (inline_call e1 e) = {}" by auto
    moreover from fin have "𝒟 (inline_call e1 e) {}"
      using call D by(rule defass_inline_call)
    moreover have "max_vars ?e2'  max_vars E + max_vars E'" by(rule inline_call_max_vars1)
    with ‹final E' length have "max_vars ?e2'  length xs" by(auto elim!: final.cases)
    ultimately have "bisim_list1 (inline_call e1 e, es1') ((?e2', xs), exs')"
      by(rule bisim_list1I) }
  ultimately show ?thesis using e1' ‹final e1 ‹final E' ex2 
    apply(simp del: τMove0.simps τMove1.simps)
    apply(rule exI conjI impI|assumption)+
     apply(rule tranclp.r_into_trancl, simp)
    apply blast
    done
qed

lemma sim_move10_into_red0:
  assumes wwf: "wwf_J_prog P"
  and sim: "sim_move10 P t ta e2 e2' e h Map.empty ta' e' h' x'"
  and fv: "fv e = {}"
  shows "if τmove1 P h e2
         then (τRed0t P t h (e, es) (e', es)  countInitBlock e2' < countInitBlock e2  e' = e  x' = Map.empty)  ta = ε  h = h'
         else e'' ta'. τRed0r P t h (e, es) (e'', es) 
                        (call1 e2 = None  call e = None  e'' = e) 
                        P,t ⊢0 e''/es,h -ta' e'/es,h' 
                        ¬ τMove0 P h (e'', es)  ta_bisim01 ta' (extTA2J1 (compP1 P) ta)"
proof(cases "τmove1 P h e2")
  case True
  with sim have "¬ final e2"
    and red: "τred0t (extTA2J0 P) P t h (e, Map.empty) (e', x') 
              countInitBlock e2' < countInitBlock e2  e' = e  x' = Map.empty"
    and [simp]: "h' = h" "ta = ε" "ta' = ε" by(simp_all add: sim_move10_def)
  from red have "τRed0t P t h (e, es) (e', es) 
                 countInitBlock e2' < countInitBlock e2  e' = e  x' = Map.empty"
  proof
    assume red: "τred0t (extTA2J0 P) P t h (e, Map.empty) (e', x')"
    from τred0t_fv_subset[OF wwf red] τred0t_dom_lcl[OF wwf red] fv
    have "dom x'  {}" by(auto split: if_split_asm)
    hence "x' = Map.empty" by auto
    with red have "τred0t (extTA2J0 P) P t h (e, Map.empty) (e', Map.empty)" by simp
    with wwf have "τRed0t P t h (e, es) (e', es)"
      using fv by(rule τred0t_into_τRed0t)
    thus ?thesis ..
  qed simp
  with True show ?thesis by simp
next
  case False
  with sim obtain e'' xs'' where "¬ final e2"
    and τred: "τred0r (extTA2J0 P) P t h (e, Map.empty) (e'', xs'')"
    and red: "extTA2J0 P,P,t  e'',(h, xs'') -ta' e',(h', x')"
    and call: "call1 e2 = None  call e = None  e'' = e"
    and "¬ τmove0 P h e''" "ta_bisim01 ta' (extTA2J1 (compP1 P) ta)" "no_call P h e''"
    by(auto simp add: sim_move10_def split: if_split_asm)
  from τred0r_fv_subset[OF wwf τred] τred0r_dom_lcl[OF wwf τred] fv
  have "dom xs''  {}" by(auto)
  hence "xs'' = Map.empty" by(auto)
  with τred have "τred0r (extTA2J0 P) P t h (e, Map.empty) (e'', Map.empty)" by simp
  with wwf have "τRed0r P t h (e, es) (e'', es)"
    using fv by(rule τred0r_into_τRed0r)
  moreover from red xs'' = Map.empty›
  have "extTA2J0 P,P,t  e'',(h, Map.empty) -ta' e',(h', x')" by simp
  from red0Red[OF this] ‹no_call P h e'' 
  have "P,t ⊢0 e''/es,h -ta' e'/es,h'" by(simp add: no_call_def)
  moreover from ¬ τmove0 P h e'' red
  have "¬ τMove0 P h (e'', es)" by auto
  ultimately show ?thesis using False ‹ta_bisim01 ta' (extTA2J1 (compP1 P) ta) call
    by(simp del: τMove0.simps) blast
qed

lemma red0_simulates_Red1:
  assumes wf: "wf_J_prog P"
  and red: "False,compP1 P,t ⊢1 ex2/exs2, h -ta ex2'/exs2', h'"
  and bisiml: "bisim_list1 (e, es) (ex2, exs2)"
  shows "e' es'. bisim_list1 (e', es') (ex2', exs2') 
                 (if τMove1 P h (ex2, exs2)
                  then (τRed0t P t h (e, es) (e', es')  countInitBlock (fst ex2') < countInitBlock (fst ex2)  exs2' = exs2  e' = e  es' = es) 
                        ta = ε  h = h'
                  else e'' es'' ta'. τRed0r P t h (e, es) (e'', es'') 
                                      (call1 (fst ex2) = None  call e = None  e'' = e  es'' = es) 
                                      P,t ⊢0 e''/es'', h -ta' e'/es', h' 
                                      ¬ τMove0 P h (e'', es'')  ta_bisim01 ta' ta)"
  (is "e' es' . _  ?red e' es'")
using red
proof(cases)
  case (red1Red E xs TA E' xs')
  note red = ‹False,compP1 P,t ⊢1 E,(h, xs) -TA E',(h', xs')
    and ex2 = ex2 = (E, xs)
    and ex2' = ex2' = (E', xs')
    and [simp] = ta = extTA2J1 (compP1 P) TA exs2' = exs2
  from bisiml ex2 have bisim: "bisim [] e E xs" and fv: "fv e = {}"
    and length: "max_vars E  length xs" and bsl: "bisim_list es exs2"
    and D: "𝒟 e {}" by(auto elim: bisim_list1_elim)
  from red_simulates_red1_aux[OF wf red, simplified, OF bisim, of Map.empty] fv length D
  obtain TA' e2' x' where red': "sim_move10 P t TA E E' e h Map.empty TA' e2' h' x'"
    and bisim'': "bisim [] e2' E' xs'" and lcl': "x' m Map.empty" by auto
  from red have "¬ final E" by auto
  with sim_move10_into_red0[OF wf_prog_wwf_prog[OF wf] red', of es] fv ex2 ex2'
  have red'': "?red e2' es" by fastforce
  moreover {
    note bsl bisim''
    moreover from red' fv have "fv e2' = {}"
      by(fastforce simp add: sim_move10_def split: if_split_asm dest: τred0r_fv_subset[OF wf_prog_wwf_prog[OF wf]] τred0t_fv_subset[OF wf_prog_wwf_prog[OF wf]] red_fv_subset[OF wf_prog_wwf_prog[OF wf]])
    moreover from red' have "dom x'  dom (Map.empty)  fv e"
      unfolding sim_move10_def
      apply(auto split: if_split_asm del: subsetI dest: τred0r_dom_lcl[OF wf_prog_wwf_prog[OF wf]] τred0t_dom_lcl[OF wf_prog_wwf_prog[OF wf]])
      apply(frule_tac [1-2] τred0r_fv_subset[OF wf_prog_wwf_prog[OF wf]])
      apply(auto dest!: τred0r_dom_lcl[OF wf_prog_wwf_prog[OF wf]] red_dom_lcl del: subsetI, blast+)
      done
    with fv have "dom x'  {}" by(auto)
    hence "x' = Map.empty" by(auto)
    with D red' have "𝒟 e2' {}"
      by(auto dest!: sim_move10_preserves_defass[OF wf] split: if_split_asm)
    moreover from red have "length xs' = length xs" by(auto dest: red1_preserves_len)
    with red1_max_vars[OF red] length
    have "max_vars E'  length xs'" by simp
    ultimately have "bisim_list1 (e2', es) ((E', xs'), exs2)"
      by(rule bisim_list1I) }
  ultimately show ?thesis using ex2'
    by(clarsimp split: if_split_asm)(rule exI conjI|assumption|simp)+
next
  case (red1Call E a M vs U Ts T body D xs)
  note [simp] = ex2 = (E, xs) h' = h ta = ε
    and ex2' = ex2' = (blocks1 0 (Class D#Ts) body, Addr a # vs @ replicate (max_vars body) undefined_value)
    and exs' = exs2' = (E, xs) # exs2
    and call = ‹call1 E = (a, M, vs) and ha = typeof_addr h a = U
    and sees = ‹compP1 P  class_type_of U sees M: TsT = body in D
    and len = ‹length vs = length Ts
  let ?e2' = "blocks1 0 (Class D#Ts) body"
  let ?xs2' = "Addr a # vs @ replicate (max_vars body) undefined_value"
  from bisiml have bisim: "bisim [] e E xs" and fv: "fv e = {}"
    and length: "max_vars E  length xs" and bsl: "bisim_list es exs2"
    and D: "𝒟 e {}" by(auto elim: bisim_list1_elim)

  from bisim ‹call1 E = (a, M, vs)
  have "call e = (a, M, vs)" by(rule bisim_call1_Some_call)
  moreover note ha
  moreover from ‹compP1 P  class_type_of U sees M: TsT = body in D
  obtain pns Jbody where sees': "P  class_type_of U sees M: TsT = (pns, Jbody) in D"
    and body: "body = compE1 (this # pns) Jbody"
    by(auto dest: sees_method_compPD)
  let ?e' = "blocks (this # pns) (Class D # Ts) (Addr a # vs) Jbody"
  note sees' moreover from wf sees' have "length Ts = length pns"
    by(auto dest!: sees_wf_mdecl simp add: wf_mdecl_def)
  with len have "length vs = length pns" "length Ts = length pns" by simp_all
  ultimately have red': "P,t ⊢0 e/es, h -ε ?e'/e#es, h" by(rule red0Call)
  moreover from ‹call e = (a, M, vs) ha sees'
  have "τMove0 P h (e, es)"
    by(fastforce simp add: synthesized_call_def dest: τmove0_callD[where P=P and h=h] sees_method_fun)
  ultimately have "τRed0t P t h (e, es) (?e', e#es)" by auto
  moreover
  from bsl bisim fv D length ‹call e = (a, M, vs) ‹call1 E = (a, M, vs)
  have "bisim_list (e # es) ((E, xs) # exs2)" by(rule bisim_list.intros)
  hence "bisim_list1 (?e', e # es) (ex2', (E, xs) # exs2)" unfolding ex2'
  proof(rule bisim_list1I)
    from wf_prog_wwf_prog[OF wf] sees'
    have "wf_mdecl wwf_J_mdecl P D (M,Ts,T,(pns,Jbody))" by(rule sees_wf_mdecl)
    hence "fv Jbody  set pns  {this}" by(auto simp add: wf_mdecl_def)
    moreover from sees' have "¬ contains_insync Jbody"
      by(auto dest!: sees_wf_mdecl[OF wf] WT_expr_locks simp add: wf_mdecl_def contains_insync_conv)
    ultimately have "bisim ([] @ this # pns) Jbody (compE1 ([] @ this # pns) Jbody) ?xs2'"
      by -(rule compE1_bisim, auto)
    with ‹length vs = length Ts ‹length Ts = length pns body
    have "bisim [] ?e' (blocks1 (length ([] :: vname list)) (Class D # Ts) body) ?xs2'"
      by -(rule blocks_bisim, auto simp add: nth_append nth_Cons')
    thus "bisim [] ?e' ?e2' ?xs2'" by simp
    from ‹length vs = length Ts ‹length Ts = length pns ‹fv Jbody  set pns  {this}
    show "fv ?e' = {}" by auto
    from wf sees'
    have "wf_mdecl wf_J_mdecl P D (M,Ts,T,(pns,Jbody))" by(rule sees_wf_mdecl)
    hence "𝒟 Jbody set pns  {this}" by(auto simp add: wf_mdecl_def)
    with ‹length vs = length Ts ‹length Ts = length pns
    have "𝒟 (blocks pns Ts vs Jbody) dom [this  Addr a]" by(auto)
    thus "𝒟 ?e' {}" by simp
    from len show "max_vars ?e2'  length ?xs2'" by(simp add: blocks1_max_vars)
  qed
  moreover have "τMove1 P h (ex2, exs2)" using ha ‹call1 E = (a, M, vs) sees'
    by(auto simp add: synthesized_call_def τexternal'_def dest!: τmove1_not_call1[where P=P and h=h] dest: sees_method_fun)
  ultimately show ?thesis using exs'
    by(simp del: τMove1.simps τMove0.simps)(rule exI conjI rtranclp.rtrancl_refl|assumption)+
next
  case (red1Return E' x' E x)
  note [simp] = h' = h ta = ε
    and ex2 = ex2 = (E', x') and exs2 = exs2 = (E, x) # exs2'
    and ex2' = ex2' = (inline_call E' E, x)
    and fin = ‹final E'
  from bisiml ex2 exs2 obtain e' es' aMvs where es: "es = e' # es'"
    and bsl: "bisim_list es' exs2'"
    and bisim: "bisim [] e E' x'"
    and bisim': "bisim [] e' E x"
    and fv: "fv e' = {}"
    and length: "max_vars E  length x"
    and D: "𝒟 e' {}"
    and call: "call e' = aMvs"
    and call1: "call1 E = aMvs"
    by(fastforce elim!: bisim_list1_elim)
  
  from ‹final E' bisim have fin': "final e" by(auto)
  hence "P,t ⊢0 e/e' # es',h -ε inline_call e e'/es',h" by(rule red0Return)
  moreover from bisim fin' bisim' call
  have "bisim [] (inline_call e e') (inline_call E' E) x"
    by(rule bisim_inline_call)(simp add: fv)
  with bsl have "bisim_list1 (inline_call e e', es') (ex2', exs2')" unfolding ex2'
  proof(rule bisim_list1I)
    from fin' fv_inline_call[of e e'] fv show "fv (inline_call e e') = {}" by auto
    from fin' show "𝒟 (inline_call e e') {}" using call D by(rule defass_inline_call)
    
    from call1_imp_call[OF call1]
    have "max_vars (inline_call E' E)  max_vars E + max_vars E'"
      by(rule inline_call_max_vars)
    with fin length show "max_vars (inline_call E' E)  length x" by(auto elim!: final.cases)
  qed
  moreover have "τMove1 P h (ex2, exs2) = τMove0 P h (e, es)" using ex2 call1 call fin fin' by(auto)
  ultimately show ?thesis using es
    by(simp del: τMove1.simps τMove0.simps) blast
qed

end

sublocale J0_J1_heap_base < red0_Red1': FWdelay_bisimulation_base
  final_expr0
  "mred0 P"
  final_expr1
  "mred1' (compP1 P)"
  convert_RA
  "λt. bisim_red0_Red1" 
  bisim_wait01
  "τMOVE0 P"
  "τMOVE1 (compP1 P)"
  for P
.

context J0_J1_heap_base begin

lemma delay_bisimulation_red0_Red1: 
  assumes wf: "wf_J_prog P"
  shows "delay_bisimulation_measure (mred0 P t) (mred1' (compP1 P) t) bisim_red0_Red1 (ta_bisim (λt. bisim_red0_Red1)) (τMOVE0 P) (τMOVE1 (compP1 P)) (λes es'. False) (λ(((e', xs'), exs'), h') (((e, xs), exs), h). countInitBlock e'< countInitBlock e)"
  (is "delay_bisimulation_measure _ _ _ _ _ _ ?μ1 ?μ2")
proof(unfold_locales)
  fix s1 s2 s1'
  assume "bisim_red0_Red1 s1 s2" "red0_mthr.silent_move P t s1 s1'"
  moreover obtain ex1 exs1 h1 where s1: "s1 = ((ex1, exs1), h1)" by(cases s1, auto)
  moreover obtain ex1' exs1' h1' where s1': "s1' = ((ex1', exs1'), h1')" by(cases s1', auto)
  moreover obtain ex2 exs2 h2 where s2: "s2 = ((ex2, exs2), h2)" by(cases s2, auto)
  ultimately have bisim: "bisim_list1 (ex1, exs1) (ex2, exs2)"
    and heap: "h1 = h2"
    and red: "P,t ⊢0 ex1/exs1,h1 -ε ex1'/exs1',h1'"
    and τ: "τMove0 P h1 (ex1, exs1)"
    by(auto simp add: bisim_red0_Red1_def red0_mthr.silent_move_iff)
  from Red1_simulates_red0[OF wf red bisim] τ
  obtain ex2'' exs2'' where bisim': "bisim_list1 (ex1', exs1') (ex2'', exs2'')" 
    and red': "τRed1't (compP1 P) t h1 (ex2, exs2) (ex2'', exs2'')"
    and [simp]: "h1' = h1" by auto
  from τRed1't_into_Red1'_τmthr_silent_movet[OF red'] bisim' heap
  have "s2'. Red1_mthr.silent_movet False (compP1 P) t s2 s2'  bisim_red0_Red1 s1' s2'"
    unfolding s2 s1' by(auto simp add: bisim_red0_Red1_def)
  thus "bisim_red0_Red1 s1' s2  ?μ1^++ s1' s1  (s2'. Red1_mthr.silent_movet False (compP1 P) t s2 s2'  bisim_red0_Red1 s1' s2')" ..
next
  fix s1 s2 s2'
  assume "bisim_red0_Red1 s1 s2" "Red1_mthr.silent_move False (compP1 P) t s2 s2'"
  moreover obtain ex1 exs1 h1 where s1: "s1 = ((ex1, exs1), h1)" by(cases s1, auto)
  moreover obtain ex2 exs2 h2 where s2: "s2 = ((ex2, exs2), h2)" by(cases s2, auto)
  moreover obtain ex2' exs2' h2' where s2': "s2' = ((ex2', exs2'), h2')" by(cases s2', auto)
  ultimately have bisim: "bisim_list1 (ex1, exs1) (ex2, exs2)"
    and heap: "h1 = h2"
    and red: "False,compP1 P,t ⊢1 ex2/exs2,h2 -ε ex2'/exs2',h2'"
    and τ: "τMove1 P h2 (ex2, exs2)"
    by(fastforce simp add: bisim_red0_Red1_def Red1_mthr.silent_move_iff)+
  from red0_simulates_Red1[OF wf red bisim] τ
  obtain e' es' where bisim': "bisim_list1 (e', es') (ex2', exs2')"
    and red': "τRed0t P t h2 (ex1, exs1) (e', es')  
               countInitBlock (fst ex2') < countInitBlock (fst ex2)  exs2' = exs2  e' = ex1  es' = exs1"
    and [simp]: "h2' = h2" by auto
  from red'
  show "bisim_red0_Red1 s1 s2'  ?μ2^++ s2' s2  (s1'. red0_mthr.silent_movet P t s1 s1'  bisim_red0_Red1 s1' s2')"
    (is "?refl  ?step")
  proof
    assume "τRed0t P t h2 (ex1, exs1) (e', es')"
    from τRed0t_into_red0_τmthr_silent_movet[OF this] bisim' heap
    have ?step unfolding s1 s2' by(auto simp add: bisim_red0_Red1_def)
    thus ?thesis ..
  next
    assume "countInitBlock (fst ex2') < countInitBlock (fst ex2)  exs2' = exs2  e' = ex1  es' = exs1"
    hence ?refl using bisim' heap unfolding s1 s2' s2
      by (auto simp add: bisim_red0_Red1_def split_beta)
    thus ?thesis ..
  qed
next
  fix s1 s2 ta1 s1'
  assume "bisim_red0_Red1 s1 s2"  and "mred0 P t s1 ta1 s1'" and τ: "¬ τMOVE0 P s1 ta1 s1'"
  moreover obtain ex1 exs1 h1 where s1: "s1 = ((ex1, exs1), h1)" by(cases s1, auto)
  moreover obtain ex1' exs1' h1' where s1': "s1' = ((ex1', exs1'), h1')" by(cases s1', auto)
  moreover obtain ex2 exs2 h2 where s2: "s2 = ((ex2, exs2), h2)" by(cases s2, auto)
  ultimately have heap: "h2 = h1"
    and bisim: "bisim_list1 (ex1, exs1) (ex2, exs2)"
    and red: "P,t ⊢0 ex1/exs1,h1 -ta1 ex1'/exs1',h1'"
    by(auto simp add: bisim_red0_Red1_def)
  from τ have "¬ τMove0 P h1 (ex1, exs1)" unfolding s1
    using red by(auto elim!: red0.cases dest: red_τ_taD[where extTA="extTA2J0 P", OF extTA2J0_ε])
  with Red1_simulates_red0[OF wf red bisim]
  obtain ex2'' exs2'' ex2' exs2' ta'
    where bisim': "bisim_list1 (ex1', exs1') (ex2'', exs2'')"
    and red': "τRed1'r (compP1 P) t h1 (ex2, exs2) (ex2', exs2')"
    and red'': "False,compP1 P,t ⊢1 ex2'/exs2',h1 -ta' ex2''/exs2'',h1'"
    and τ': "¬ τMove1 P h1 (ex2', exs2')"
    and ta: "ta_bisim01 ta1 ta'" by fastforce
  from red'' have "mred1' (compP1 P) t ((ex2', exs2'), h1) ta' ((ex2'', exs2''), h1')" by auto
  moreover from τ' have "¬ τMOVE1 (compP1 P) ((ex2', exs2'), h1) ta' ((ex2'', exs2''), h1')" by simp
  moreover from red' have "Red1_mthr.silent_moves False (compP1 P) t s2 ((ex2', exs2'), h1)"
    unfolding s2 heap by(rule τRed1'r_into_Red1'_τmthr_silent_moves)
  moreover from bisim' have "bisim_red0_Red1 ((ex1', exs1'), h1') ((ex2'', exs2''), h1')"
    by(auto simp add: bisim_red0_Red1_def)
  ultimately
  show "s2' s2'' ta2. Red1_mthr.silent_moves False (compP1 P) t s2 s2'  mred1' (compP1 P) t s2' ta2 s2'' 
             ¬ τMOVE1 (compP1 P) s2' ta2 s2''  bisim_red0_Red1 s1' s2''  ta_bisim01 ta1 ta2"
    using ta unfolding s1' by blast
next
  fix s1 s2 ta2 s2'
  assume "bisim_red0_Red1 s1 s2"  and "mred1' (compP1 P) t s2 ta2 s2'" and τ: "¬ τMOVE1 (compP1 P) s2 ta2 s2'"
  moreover obtain ex1 exs1 h1 where s1: "s1 = ((ex1, exs1), h1)" by(cases s1, auto)
  moreover obtain ex2 exs2 h2 where s2: "s2 = ((ex2, exs2), h2)" by(cases s2, auto)
  moreover obtain ex2' exs2' h2' where s2': "s2' = ((ex2', exs2'), h2')" by(cases s2', auto)
  ultimately have heap: "h2 = h1"
    and bisim: "bisim_list1 (ex1, exs1) (ex2, exs2)"
    and red: "False,compP1 P,t ⊢1 ex2/exs2,h1 -ta2 ex2'/exs2',h2'"
    by(auto simp add: bisim_red0_Red1_def)
  from τ heap have "¬ τMove1 P h2 (ex2, exs2)" unfolding s2
    using red by(fastforce elim!: Red1.cases dest: red1_τ_taD)
  with red0_simulates_Red1[OF wf red bisim]
  obtain e' es' e'' es'' ta'
    where bisim': "bisim_list1 (e', es') (ex2', exs2')"
    and red': "τRed0r P t h1 (ex1, exs1) (e'', es'')"
    and red'': "P,t ⊢0 e''/es'',h1 -ta' e'/es',h2'"
    and τ': "¬ τMove0 P h1 (e'', es'')"
    and ta: "ta_bisim01 ta' ta2" using heap by fastforce
  from red'' have "mred0 P t ((e'', es''), h1) ta' ((e', es'), h2')" by auto
  moreover from red' have "red0_mthr.silent_moves P t ((ex1, exs1), h1) ((e'', es''), h1)"
    by(rule τRed0r_into_red0_τmthr_silent_moves)
  moreover from τ' have "¬ τMOVE0 P ((e'', es''), h1) ta' ((e', es'), h2')" by simp
  moreover from bisim' have "bisim_red0_Red1 ((e', es'), h2') ((ex2', exs2'), h2')"
    by(auto simp add: bisim_red0_Red1_def)
  ultimately
  show "s1' s1'' ta1. red0_mthr.silent_moves P t s1 s1' 
             mred0 P t s1' ta1 s1''  ¬ τMOVE0 P s1' ta1 s1'' 
             bisim_red0_Red1 s1'' s2'  ta_bisim01 ta1 ta2"
    using ta unfolding s1 s2' by blast
next
  show "wfP ?μ1" by auto
next
  have "wf (measure countInitBlock)" ..
  hence "wf (inv_image (measure countInitBlock) (λ(((e', xs'), exs'), h'). e'))" ..
  also have "inv_image (measure countInitBlock) (λ(((e', xs'), exs'), h'). e') = {(s2', s2). ?μ2 s2' s2}"
    by(simp add: inv_image_def split_beta)
  finally show "wfP ?μ2" by(simp add: wfP_def)
qed

lemma delay_bisimulation_diverge_red0_Red1: 
  assumes "wf_J_prog P"
  shows "delay_bisimulation_diverge (mred0 P t) (mred1' (compP1 P) t) bisim_red0_Red1 (ta_bisim (λt. bisim_red0_Red1)) (τMOVE0 P) (τMOVE1 (compP1 P))"
proof -
  interpret delay_bisimulation_measure
    "mred0 P t" "mred1' (compP1 P) t" "bisim_red0_Red1" "ta_bisim (λt. bisim_red0_Red1)" "τMOVE0 P" "τMOVE1 (compP1 P)"
    "λes es'. False" "λ(((e', xs'), exs'), h') (((e, xs), exs), h). countInitBlock e'< countInitBlock e"
    using assms by(rule delay_bisimulation_red0_Red1)
  show ?thesis by unfold_locales
qed

lemma red0_Red1'_FWweak_bisim:
  assumes wf: "wf_J_prog P"
  shows "FWdelay_bisimulation_diverge final_expr0 (mred0 P) final_expr1 (mred1' (compP1 P))
           (λt. bisim_red0_Red1) bisim_wait01 (τMOVE0 P) (τMOVE1 (compP1 P))"
proof -
  interpret delay_bisimulation_diverge
    "mred0 P t"
    "mred1' (compP1 P) t" 
    bisim_red0_Red1 
    "ta_bisim (λt. bisim_red0_Red1)" "τMOVE0 P" "τMOVE1 (compP1 P)"
    for t
    using wf by(rule delay_bisimulation_diverge_red0_Red1)
  show ?thesis
  proof
    fix t and s1 and s2 :: "(('addr expr1 × 'addr locals1) × ('addr expr1 × 'addr locals1) list) × 'heap"
    assume "bisim_red0_Red1 s1 s2" "(λ(x1, m). final_expr0 x1) s1"
    moreover hence "(λ(x2, m). final_expr1 x2) s2"
      by(cases s1)(cases s2,auto simp add: bisim_red0_Red1_def final_iff elim!: bisim_list1_elim elim: bisim_list.cases)
    ultimately show "s2'. Red1_mthr.silent_moves False (compP1 P) t s2 s2'  bisim_red0_Red1 s1 s2'  (λ(x2, m). final_expr1 x2) s2'"
      by blast
  next
    fix t s1 and s2 :: "(('addr expr1 × 'addr locals1) × ('addr expr1 × 'addr locals1) list) × 'heap"
    assume "bisim_red0_Red1 s1 s2" "(λ(x2, m). final_expr1 x2) s2"
    moreover hence "(λ(x1, m). final_expr0 x1) s1"
      by(cases s1)(cases s2,auto simp add: bisim_red0_Red1_def final_iff elim!: bisim_list1_elim elim: bisim_list.cases)
    ultimately show "s1'. red0_mthr.silent_moves P t s1 s1'  bisim_red0_Red1 s1' s2  (λ(x1, m). final_expr0 x1) s1'"
      by blast
  next
    fix t' x m1 x' m2 t x1 x2 x1' ta1 x1'' m1' x2' ta2 x2'' m2'
    assume b: "bisim_red0_Red1 (x, m1) (x', m2)"
      and bo: "bisim_red0_Red1 (x1, m1) (x2, m2)"
      and τred1: "red0_mthr.silent_moves P t (x1, m1) (x1', m1)"
      and red1: "mred0 P t (x1', m1) ta1 (x1'', m1')"
      and τ1: "¬ τMOVE0 P (x1', m1) ta1 (x1'', m1')"
      and τred2: "Red1_mthr.silent_moves False (compP1 P) t (x2, m2) (x2', m2)"
      and red2: "mred1' (compP1 P) t (x2', m2) ta2 (x2'', m2')"
      and bo': "bisim_red0_Red1 (x1'', m1') (x2'', m2')"
      and tb: "ta_bisim (λt. bisim_red0_Red1) ta1 ta2"
    from b have "m1 = m2" by(auto simp add: bisim_red0_Red1_def split_beta)
    moreover from bo' have "m1' = m2'" by(auto simp add: bisim_red0_Red1_def split_beta)
    ultimately show "bisim_red0_Red1 (x, m1') (x', m2')" using b
      by(auto simp add: bisim_red0_Red1_def split_beta)
  next
    fix t x1 m1 x2 m2 x1' ta1 x1'' m1' x2' ta2 x2'' m2' w
    assume "bisim_red0_Red1 (x1, m1) (x2, m2)"
      and "red0_mthr.silent_moves P t (x1, m1) (x1', m1)"
      and red0: "mred0 P t (x1', m1) ta1 (x1'', m1')"
      and "¬ τMOVE0 P (x1', m1) ta1 (x1'', m1')"
      and "Red1_mthr.silent_moves False (compP1 P) t (x2, m2) (x2', m2)"
      and red1: "mred1' (compP1 P) t (x2', m2) ta2 (x2'', m2')"
      and "¬ τMOVE1 (compP1 P) (x2', m2) ta2 (x2'', m2')"
      and "bisim_red0_Red1 (x1'', m1') (x2'', m2')"
      and "ta_bisim01 ta1 ta2"
      and Suspend: "Suspend w  set ta1w" "Suspend w  set ta2w"
    from red0 red1 Suspend show "bisim_wait01 x1'' x2''"
      by(cases x2')(cases x2'', auto dest: Red_Suspend_is_call Red1_Suspend_is_call simp add: split_beta bisim_wait01_def is_call_def)
  next
    fix t x1 m1 x2 m2 ta1 x1' m1'
    assume "bisim_red0_Red1 (x1, m1) (x2, m2)"
      and "bisim_wait01 x1 x2"
      and "mred0 P t (x1, m1) ta1 (x1', m1')"
      and wakeup: "Notified  set ta1w  WokenUp  set ta1w"
    moreover obtain e0 es0 where [simp]: "x1 = (e0, es0)" by(cases x1)
    moreover obtain e0' es0' where [simp]: "x1' = (e0', es0')" by(cases x1')
    moreover obtain e1 xs1 exs1 where [simp]: "x2 = ((e1, xs1), exs1)" by(cases x2) auto
    ultimately have bisim: "bisim_list1 (e0, es0) ((e1, xs1), exs1)"
      and m1: "m2 = m1"
      and call: "call e0  None" "call1 e1  None"
      and red: "P,t ⊢0 e0/es0, m1 -ta1 e0'/es0', m1'"
      by(auto simp add: bisim_wait01_def bisim_red0_Red1_def)
    from red wakeup have "¬ τMove0 P m1 (e0, es0)"
      by(auto elim!: red0.cases dest: red_τ_taD[where extTA="extTA2J0 P", simplified])
    with Red1_simulates_red0[OF wf red bisim] call m1
    show "ta2 x2' m2'. mred1' (compP1 P) t (x2, m2) ta2 (x2', m2')  bisim_red0_Red1 (x1', m1') (x2', m2')  ta_bisim01 ta1 ta2"
      by(auto simp add: bisim_red0_Red1_def)
  next
    fix t x1 m1 x2 m2 ta2 x2' m2'
    assume "bisim_red0_Red1 (x1, m1) (x2, m2)"
      and "bisim_wait01 x1 x2" 
      and "mred1' (compP1 P) t (x2, m2) ta2 (x2', m2')"
      and wakeup: "Notified  set ta2w  WokenUp  set ta2w"
    moreover obtain e0 es0 where [simp]: "x1 = (e0, es0)" by(cases x1)
    moreover obtain e1 xs1 exs1 where [simp]: "x2 = ((e1, xs1), exs1)" by(cases x2) auto
    moreover obtain e1' xs1' exs1' where [simp]: "x2' = ((e1', xs1'), exs1')" by(cases x2') auto
    ultimately have bisim: "bisim_list1 (e0, es0) ((e1, xs1), exs1)"
      and m1: "m2 = m1"
      and call: "call e0  None" "call1 e1  None"
      and red: "False,compP1 P,t ⊢1 (e1, xs1)/exs1, m1 -ta2 (e1', xs1')/exs1', m2'"
      by(auto simp add: bisim_wait01_def bisim_red0_Red1_def)
    from red wakeup have "¬ τMove1 P m1 ((e1, xs1), exs1)"
      by(auto elim!: Red1.cases dest: red1_τ_taD)
    with red0_simulates_Red1[OF wf red bisim] m1 call
    show "ta1 x1' m1'. mred0 P t (x1, m1) ta1 (x1', m1')  bisim_red0_Red1 (x1', m1') (x2', m2')  ta_bisim01 ta1 ta2"
      by(auto simp add: bisim_red0_Red1_def)
  next
    show "(x. final_expr0 x)  (x. final_expr1 x)"
      by(auto simp add: split_paired_Ex final_iff)
  qed
qed

lemma bisim_J0_J1_start:
  assumes wf: "wf_J_prog P"
  and start: "wf_start_state P C M vs"
  shows "red0_Red1'.mbisim (J0_start_state P C M vs) (J1_start_state (compP1 P) C M vs)"
proof -
  from start obtain Ts T pns body D
    where sees: "P  C sees M:TsT=(pns,body) in D"
    and conf: "P,start_heap  vs [:≤] Ts"
    by cases auto
  from conf have vs: "length vs = length Ts" by(rule list_all2_lengthD)
  from sees_wf_mdecl[OF wf_prog_wwf_prog[OF wf] sees]
  have fvbody: "fv body  {this}  set pns" and len: "length pns = length Ts"
    by(auto simp add: wf_mdecl_def)
  with vs have fv: "fv (blocks pns Ts vs body)  {this}" by auto
  have wfCM: "wf_J_mdecl P D (M, Ts, T, pns, body)"
    using sees_wf_mdecl[OF wf sees] by(auto simp add: wf_mdecl_def)
  then obtain T' where wtbody: "P,[this # pns [↦] Class D # Ts]  body :: T'" by auto
  hence elbody: "expr_locks body = (λl. 0)" by(rule WT_expr_locks)
  hence cisbody: "¬ contains_insync body" by(auto simp add: contains_insync_conv)
  from wfCM len vs have dabody: "𝒟 (blocks pns Ts vs body) {this}" by auto
  from sees have sees1: "compP1 P  C sees M:TsT = compE1 (this # pns) body in D"
    by(auto dest: sees_method_compP[where f="(λC M Ts T (pns, body). compE1 (this # pns) body)"])

  let ?e = "blocks1 0 (Class C#Ts) (compE1 (this # pns) body)"
  let ?xs = "Null # vs @ replicate (max_vars body) undefined_value"
  from fvbody cisbody len vs
  have "bisim [] (blocks (this # pns) (Class D # Ts) (Null # vs) body) (blocks1 (length ([] :: vname list)) (Class D # Ts) (compE1 (this # pns) body)) ?xs"
    by-(rule blocks_bisim,(fastforce simp add: nth_Cons' nth_append)+)
  with fv dabody len vs elbody sees sees1
  show ?thesis unfolding start_state_def
    by(auto intro!: red0_Red1'.mbisimI split: if_split_asm)(auto simp add: bisim_red0_Red1_def blocks1_max_vars intro!: bisim_list.intros bisim_list1I wset_thread_okI)
qed

end

end

Theory JJ1WellForm

(*  Title:      JinjaThreads/Compiler/JJ1WellForm.thy
    Author:     Andreas Lochbihler

    Reminiscent of the Jinja theory Compiler/Correctness1
*)

section ‹Preservation of well-formedness from source code to intermediate language›

theory JJ1WellForm imports
  "../J/JWellForm"
  J1WellForm
  Compiler1
begin

text‹The compiler preserves well-formedness. Is less trivial than it
may appear. We start with two simple properties: preservation of
well-typedness›

lemma assumes wf: "wf_prog wfmd P"
  shows compE1_pres_wt: " P,[Vs[↦]Ts]  e :: U; size Ts = size Vs   compP f P,Ts ⊢1 compE1 Vs e :: U"
  and compEs1_pres_wt: " P,[Vs[↦]Ts]  es [::] Us; size Ts = size Vs   compP f P,Ts ⊢1 compEs1 Vs es [::] Us"
proof(induct Vs e and Vs es arbitrary: Ts U and Ts Us rule: compE1_compEs1_induct)
  case Var thus ?case by(fastforce simp:map_upds_apply_eq_Some split:if_split_asm)
next
  case LAss thus ?case by(fastforce simp:map_upds_apply_eq_Some split:if_split_asm)
next
  case Call thus ?case
    by(fastforce dest: sees_method_compP[where f = f])
next
  case Block thus ?case by(fastforce simp:nth_append)
next
  case (Synchronized Vs V exp1 exp2 Ts U)
  note IH1 = Ts U. P,[Vs [↦] Ts]  exp1 :: U;
    length Ts = length Vs  compP f P,Ts ⊢1 compE1 Vs exp1 :: U
  note IH2 = Ts U. P,[(Vs @ [fresh_var Vs]) [↦] Ts]  exp2 :: U; length Ts = length (Vs @ [fresh_var Vs])
       compP f P,Ts ⊢1 compE1 (Vs @ [fresh_var Vs]) exp2 :: U
  note length = ‹length Ts = length Vs
  from P,[Vs [↦] Ts]  syncV (exp1) exp2 :: U
  obtain U1 where wt1: "P,[Vs [↦] Ts]  exp1 :: U1"
    and wt2: "P,[Vs [↦] Ts]  exp2 :: U"
    and U1: "is_refT U1" "U1  NT"
    by(auto)
  from IH1[of Ts U1] wt1 length
  have wt1': "compP f P,Ts ⊢1 compE1 Vs exp1 :: U1" by simp
  from length fresh_var_fresh[of Vs] have "[Vs [↦] Ts] m [Vs @ [fresh_var Vs] [↦] Ts @ [Class Object]]"
    by(auto simp add: map_le_def fun_upd_def)
  with wt2 have "P,[Vs@[fresh_var Vs] [↦] Ts @ [Class Object]]  exp2 :: U"
    by(rule wt_env_mono)
  with length IH2[of "Ts @ [Class Object]" U]
  have "compP f P,Ts @ [Class Object] ⊢1 compE1 (Vs @ [fresh_var Vs]) exp2 :: U" by simp
  with wt1' U1 show ?case by(auto)
next 
  case (TryCatch Vs exp1 C V exp2)
  note IH1 = Ts U. P,[Vs [↦] Ts]  exp1 :: U; length Ts = length Vs  compP f P,Ts ⊢1 compE1 Vs exp1 :: U
  note IH2 = Ts U. P,[(Vs @ [V]) [↦] Ts]  exp2 :: U; length Ts = length (Vs @ [V])  compP f P,Ts ⊢1 compE1 (Vs @ [V]) exp2 :: U
  note length = ‹length Ts = length Vs
  with P,[Vs [↦] Ts]  try exp1 catch(C V) exp2 :: U
  have wt1: "P,[Vs [↦] Ts]  exp1 :: U" and wt2: "P,[(Vs@[V]) [↦] (Ts@[Class C])]  exp2 :: U"
    and C: "P  C * Throwable" by(auto simp add: nth_append)
  from wf C have "is_class P C" by(rule is_class_sub_Throwable)
  with IH1[OF wt1 length] IH2[OF wt2] length show ?case by(auto)
qed(fastforce)+


text‹\noindent and the correct block numbering:›

text‹The main complication is preservation of definite assignment
@{term"𝒟"}.›

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows A_compE1_None[simp]: "𝒜 e = None  𝒜 (compE1 Vs e) = None"
  and As_compEs1_None: "𝒜s es = None  𝒜s (compEs1 Vs es) = None"
apply(induct Vs e and Vs es rule: compE1_compEs1_induct)
apply(auto simp:hyperset_defs)
done

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows A_compE1: " 𝒜 e = A; fv e  set Vs   𝒜 (compE1 Vs e) = index Vs ` A"
  and As_compEs1: " 𝒜s es = A; fvs es  set Vs   𝒜s (compEs1 Vs es) = index Vs ` A"
proof(induct Vs e and Vs es arbitrary: A and A rule: compE1_compEs1_induct)
  case (Block Vs V' T vo e)
  hence "fv e  set (Vs@[V'])" by fastforce
  moreover obtain B where "𝒜 e = B"
    using Block.prems by(simp add: hyperset_defs)
  moreover from calculation have "B  set (Vs@[V'])" by(auto dest!:A_fv)
  ultimately show ?case using Block
    by(auto simp add: hyperset_defs image_index)
next
  case (Synchronized Vs V exp1 exp2 A)
  have IH1: "A. 𝒜 exp1 = A; fv exp1  set Vs  𝒜 (compE1 Vs exp1) = index Vs ` A" by fact
  have IH2: "A. 𝒜 exp2 = A; fv exp2  set (Vs @ [fresh_var Vs])  𝒜 (compE1 (Vs @ [fresh_var Vs]) exp2) = index (Vs @ [fresh_var Vs]) ` A" by fact
  from ‹fv (syncV (exp1) exp2)  set Vs 
  have fv1: "fv exp1  set Vs"
    and fv2: "fv exp2  set Vs" by auto
  from ‹𝒜 (syncV (exp1) exp2) = A have A: "𝒜 exp1  𝒜 exp2 = A" by(simp)
  then obtain A1 A2 where A1: "𝒜 exp1 = A1" and A2: "𝒜 exp2 = A2" by(auto simp add: hyperset_defs)
  from A2 fv2 have "A2  set Vs" by(auto dest: A_fv del: subsetI)
  with fresh_var_fresh[of Vs] have "(fresh_var Vs)  A2" by(auto)
  from fv2 have "fv exp2  set (Vs @ [fresh_var Vs])" by auto
  with IH2[OF A2] have "𝒜 (compE1 (Vs @ [fresh_var Vs]) exp2) = index (Vs @ [fresh_var Vs]) ` A2" by(auto)
  with IH1[OF A1 fv1] A[symmetric] A2  set Vs (fresh_var Vs)  A2 A1 A2 show ?case
    by(auto simp add: image_index)
next
  case (InSynchronized Vs V a exp A)
  have IH: "A. 𝒜 exp = A; fv exp  set (Vs @ [fresh_var Vs])  𝒜 (compE1 (Vs @ [fresh_var Vs]) exp) = index (Vs @ [fresh_var Vs]) ` A" by fact
  from ‹𝒜 (insyncV (a) exp) = A have A: "𝒜 exp = A" by simp
  from ‹fv (insyncV (a) exp)  set Vs have fv: "fv exp  set Vs" by simp
  from A fv have "A  set Vs" by(auto dest: A_fv del: subsetI)
  with fresh_var_fresh[of Vs] have "(fresh_var Vs)  A" by(auto)
  from fv IH[OF A] have " 𝒜 (compE1 (Vs @ [fresh_var Vs]) exp) = index (Vs @ [fresh_var Vs]) ` A" by simp
  with A  set Vs (fresh_var Vs)  A show ?case by(simp add: image_index)
next
  case (TryCatch Vs e1 C V' e2)
  hence fve2: "fv e2  set (Vs@[V'])" by auto
  show ?case
  proof (cases "𝒜 e1")
    assume A1: "𝒜 e1 = None"
    then obtain A2 where A2: "𝒜 e2 = A2" using TryCatch
      by(simp add:hyperset_defs)
    hence "A2  set (Vs@[V'])" using TryCatch.prems A_fv[OF A2] by simp blast
    thus ?thesis using TryCatch fve2 A1 A2
      by(auto simp add:hyperset_defs image_index)
  next
    fix A1 assume A1: "𝒜 e1 =  A1"
    show ?thesis
    proof (cases  "𝒜 e2")
      assume A2: "𝒜 e2 = None"
      then show ?case using TryCatch A1 by(simp add:hyperset_defs)
    next
      fix A2 assume A2: "𝒜 e2 = A2"
      have "A1  set Vs" using TryCatch.prems A_fv[OF A1] by simp blast
      moreover
      have "A2  set (Vs@[V'])" using TryCatch.prems A_fv[OF A2] by simp blast
      ultimately show ?thesis using TryCatch A1 A2
        by(fastforce simp add: hyperset_defs image_index
          Diff_subset_conv inj_on_image_Int[OF inj_on_index])
    qed
  qed
next
  case (Cond Vs e e1 e2)
  { assume "𝒜 e = None  𝒜 e1 = None  𝒜 e2 = None"
    hence ?case using Cond by(auto simp add:hyperset_defs image_Un)
  }
  moreover
  { fix A A1 A2
    assume "𝒜 e = A" and A1: "𝒜 e1 = A1" and A2: "𝒜 e2 = A2"
    moreover
    have "A1  set Vs" using Cond.prems A_fv[OF A1] by simp blast
    moreover
    have "A2  set Vs" using Cond.prems A_fv[OF A2] by simp blast
    ultimately have ?case using Cond
      by(auto simp add:hyperset_defs image_Un
          inj_on_image_Int[OF inj_on_index])
  }
  ultimately show ?case by fastforce
qed (auto simp add:hyperset_defs)

lemma fixes e :: "('a, 'b, 'addr) exp" and es :: "('a, 'b, 'addr) exp list"
  shows D_None [iff]: "𝒟 e None"
  and Ds_None [iff]: "𝒟s es None"
by(induct e and es rule: 𝒟.induct 𝒟s.induct)(simp_all)

declare Un_ac [simp]

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows D_index_compE1: " A  set Vs; fv e  set Vs   𝒟 e A  𝒟 (compE1 Vs e) index Vs ` A"
  and Ds_index_compEs1: " A  set Vs; fvs es  set Vs   𝒟s es A  𝒟s (compEs1 Vs es) index Vs ` A"
proof(induct e and es arbitrary: A Vs and A Vs rule: 𝒟.induct 𝒟s.induct)
  case (BinOp e1 bop e2)
  hence IH1: "𝒟 (compE1 Vs e1) index Vs ` A" by simp
  show ?case
  proof (cases "𝒜 e1")
    case None thus ?thesis using BinOp by simp
  next
    case (Some A1)
    have indexA1: "𝒜 (compE1 Vs e1) = index Vs ` A1"
      using A_compE1[OF Some] BinOp.prems  by auto
    have "A  A1  set Vs" using BinOp.prems A_fv[OF Some] by auto
    hence "𝒟 (compE1 Vs e2) index Vs ` (A1  A)" using BinOp Some by(auto)
    hence "𝒟 (compE1 Vs e2) index Vs ` A1  index Vs ` A"
      by(simp add: image_Un)
    thus ?thesis using IH1 indexA1 by auto
  qed
next
  case (AAcc a i A Vs)
  have IH1: "A Vs. A  set Vs; fv a  set Vs; 𝒟 a A  𝒟 (compE1 Vs a) index Vs ` A" by fact
  have IH2: "A Vs. A  set Vs; fv i  set Vs; 𝒟 i A  𝒟 (compE1 Vs i) index Vs ` A" by fact
  from ‹𝒟 (ai) A have D1: "𝒟 a A" and D2: "𝒟 i (A  𝒜 a)" by auto
  from ‹fv (ai)  set Vs have fv1: "fv a  set Vs" and fv2: "fv i  set Vs" by auto
  show ?case
  proof(cases "𝒜 a")
    case None thus ?thesis using AAcc by simp
  next
    case (Some A1)
    with fv1 have "𝒜 (compE1 Vs a) = index Vs ` A1" by-(rule A_compE1)
    moreover from A_fv[OF Some] fv1 A  set Vs have "A1  A  set Vs" by auto
    from IH2[OF this fv2] Some D2 have "𝒟 (compE1 Vs i) index Vs ` A1  index Vs ` A"
      by(simp add: image_Un)
    ultimately show ?thesis using IH1[OF A  set Vs fv1 D1] by(simp)
  qed
next
  case (AAss a i e A Vs)
  have IH1: "A Vs. A  set Vs; fv a  set Vs; 𝒟 a A  𝒟 (compE1 Vs a) index Vs ` A" by fact
  have IH2: "A Vs. A  set Vs; fv i  set Vs; 𝒟 i A  𝒟 (compE1 Vs i) index Vs ` A" by fact
  have IH3: "A Vs. A  set Vs; fv e  set Vs; 𝒟 e A  𝒟 (compE1 Vs e) index Vs ` A" by fact
  from ‹𝒟 (ai:=e) A have D1: "𝒟 a A" and D2: "𝒟 i (A  𝒜 a)" 
    and D3: "𝒟 e (A  𝒜 a  𝒜 i)" by auto
  from ‹fv (ai := e)  set Vs
  have fv1: "fv a  set Vs" and fv2: "fv i  set Vs" and fv3: "fv e  set Vs" by auto
  show ?case
  proof(cases "𝒜 a")
    case None thus ?thesis using AAss by simp
  next
    case (Some A1)
    with fv1 have A1: "𝒜 (compE1 Vs a) = index Vs ` A1" by-(rule A_compE1)
    from A_fv[OF Some] fv1 A  set Vs have "A1  A  set Vs" by auto
    from IH2[OF this fv2] Some D2 have D2': "𝒟 (compE1 Vs i) index Vs ` A1  index Vs ` A"
      by(simp add: image_Un)
    show ?thesis
    proof(cases "𝒜 i")
      case None thus ?thesis using AAss D2' Some A1 by simp
    next
      case (Some A2)
      with fv2 have A2: "𝒜 (compE1 Vs i) = index Vs ` A2" by-(rule A_compE1)
      moreover from A_fv[OF Some] fv2 A1  A  set Vs have "A1  A  A2  set Vs" by auto
      from IH3[OF this fv3] Some ‹𝒜 a = A1 D3
      have "𝒟 (compE1 Vs e) index Vs ` A1  index Vs ` A  index Vs ` A2"
        by(simp add: image_Un Un_commute Un_assoc)
      ultimately show ?thesis using IH1[OF A  set Vs fv1 D1] D2' A1 A2 by(simp)
    qed
  qed
next
  case (FAss e1 F D e2)
  hence IH1: "𝒟 (compE1 Vs e1) index Vs ` A" by simp
  show ?case
  proof (cases "𝒜 e1")
    case None thus ?thesis using FAss by simp
  next
    case (Some A1)
    have indexA1: "𝒜 (compE1 Vs e1) = index Vs ` A1"
      using A_compE1[OF Some] FAss.prems  by auto
    have "A  A1  set Vs" using FAss.prems A_fv[OF Some] by auto
    hence "𝒟 (compE1 Vs e2) index Vs ` (A  A1)" using FAss Some by auto
    hence "𝒟 (compE1 Vs e2) index Vs ` A  index Vs ` A1"
      by(simp add: image_Un)
    thus ?thesis using IH1 indexA1 by auto
  qed
next
  case (CompareAndSwap e1 D F e2 e3 A Vs)
  have IH1: "A Vs. A  set Vs; fv e1  set Vs; 𝒟 e1 A  𝒟 (compE1 Vs e1) index Vs ` A" by fact
  have IH2: "A Vs. A  set Vs; fv e2  set Vs; 𝒟 e2 A  𝒟 (compE1 Vs e2) index Vs ` A" by fact
  have IH3: "A Vs. A  set Vs; fv e3  set Vs; 𝒟 e3 A  𝒟 (compE1 Vs e3) index Vs ` A" by fact
  from ‹𝒟 (e1∙compareAndSwap(DF, e2, e3)) A have D1: "𝒟 e1 A" and D2: "𝒟 e2 (A  𝒜 e1)" 
    and D3: "𝒟 e3 (A  𝒜 e1  𝒜 e2)" by auto
  from ‹fv (e1∙compareAndSwap(DF, e2, e3))  set Vs
  have fv1: "fv e1  set Vs" and fv2: "fv e2  set Vs" and fv3: "fv e3  set Vs" by auto
  show ?case
  proof(cases "𝒜 e1")
    case None thus ?thesis using CompareAndSwap by simp
  next
    case (Some A1)
    with fv1 have A1: "𝒜 (compE1 Vs e1) = index Vs ` A1" by-(rule A_compE1)
    from A_fv[OF Some] fv1 A  set Vs have "A1  A  set Vs" by auto
    from IH2[OF this fv2] Some D2 have D2': "𝒟 (compE1 Vs e2) index Vs ` A1  index Vs ` A"
      by(simp add: image_Un)
    show ?thesis
    proof(cases "𝒜 e2")
      case None thus ?thesis using CompareAndSwap D2' Some A1 by simp
    next
      case (Some A2)
      with fv2 have A2: "𝒜 (compE1 Vs e2) = index Vs ` A2" by-(rule A_compE1)
      moreover from A_fv[OF Some] fv2 A1  A  set Vs have "A1  A  A2  set Vs" by auto
      from IH3[OF this fv3] Some ‹𝒜 e1 = A1 D3
      have "𝒟 (compE1 Vs e3) index Vs ` A1  index Vs ` A  index Vs ` A2"
        by(simp add: image_Un Un_commute Un_assoc)
      ultimately show ?thesis using IH1[OF A  set Vs fv1 D1] D2' A1 A2 by(simp)
    qed
  qed
next
  case (Call e1 M es)
  hence IH1: "𝒟 (compE1 Vs e1) index Vs ` A" by simp
  show ?case
  proof (cases "𝒜 e1")
    case None thus ?thesis using Call by simp
  next
    case (Some A1)
    have indexA1: "𝒜 (compE1 Vs e1) = index Vs ` A1"
      using A_compE1[OF Some] Call.prems  by auto
    have "A  A1  set Vs" using Call.prems A_fv[OF Some] by auto
    hence "𝒟s (compEs1 Vs es) index Vs ` (A  A1)" using Call Some by auto
    hence "𝒟s (compEs1 Vs es) index Vs ` A  index Vs ` A1"
      by(simp add: image_Un)
    thus ?thesis using IH1 indexA1 by auto
  qed
next
  case (Synchronized V exp1 exp2 A Vs)
  have IH1: "A Vs. A  set Vs; fv exp1  set Vs; 𝒟 exp1 A  𝒟 (compE1 Vs exp1) index Vs ` A" by fact
  have IH2: "A Vs. A  set Vs; fv exp2  set Vs; 𝒟 exp2 A  𝒟 (compE1 Vs exp2) index Vs ` A" by fact
  from ‹𝒟 (syncV (exp1) exp2) A have D1: "𝒟 exp1 A" and D2: "𝒟 exp2 (A  𝒜 exp1)" by auto
  from ‹fv (syncV (exp1) exp2)  set Vs have fv1: "fv exp1  set Vs" and fv2: "fv exp2  set Vs" by auto
  show ?case
  proof(cases "𝒜 exp1")
    case None thus ?thesis using Synchronized by(simp)
  next
    case (Some A1)
    with fv1 have A1: "𝒜 (compE1 Vs exp1) = index Vs ` A1" by-(rule A_compE1)
    from A_fv[OF Some] fv1 A  set Vs have "A  A1  set Vs" by auto
    hence "A  A1  set (Vs @ [fresh_var Vs])" by simp
    from IH2[OF this] fv2 Some D2
    have D2': "𝒟 (compE1 (Vs @ [fresh_var Vs]) exp2) index (Vs @ [fresh_var Vs]) ` (A  A1)"
      by(simp)
    moreover from fresh_var_fresh[of Vs] A  A1  set Vs
    have "(fresh_var Vs)  A  A1" by auto
    with A  A1  set Vs
    have "index (Vs @ [fresh_var Vs]) ` (A  A1) = index Vs ` A  index Vs ` A1"
      by(simp add: image_index image_Un)
    ultimately show ?thesis using IH1[OF A  set Vs fv1 D1] D2' A1 by(simp)
  qed
next
  case (InSynchronized V a e A Vs)
  have IH: "A Vs. A  set Vs; fv e  set Vs; 𝒟 e A  𝒟 (compE1 Vs e) index Vs ` A" by fact
  from IH[of A "Vs @ [fresh_var Vs]"] A  set Vs ‹fv (insyncV (a) e)  set Vs ‹𝒟 (insyncV (a) e) A
  have "𝒟 (compE1 (Vs @ [fresh_var Vs]) e) index (Vs @ [fresh_var Vs]) ` A" by(auto)
  moreover from fresh_var_fresh[of Vs] A  set Vs have "(fresh_var Vs)  A" by auto
  with A  set Vs have "index (Vs @ [fresh_var Vs]) ` A = index Vs ` A" by(simp add: image_index)
  ultimately show ?case by(simp)
next
  case (TryCatch e1 C V e2)
  have " A{V}  set(Vs@[V]); fv e2  set(Vs@[V]); 𝒟 e2 A{V} 
        𝒟 (compE1 (Vs@[V]) e2) index (Vs@[V]) ` (A{V})" by fact
  hence "𝒟 (compE1 (Vs@[V]) e2) index (Vs@[V]) ` (A{V})"
    using TryCatch.prems by(simp add:Diff_subset_conv)
  moreover have "index (Vs@[V]) ` A  index Vs ` A  {size Vs}"
    using TryCatch.prems by(auto simp add: image_index split:if_split_asm)
  ultimately show ?case using TryCatch by(auto simp:hyperset_defs elim!:D_mono')
next
  case (Seq e1 e2)
  hence IH1: "𝒟 (compE1 Vs e1) index Vs ` A" by simp
  show ?case
  proof (cases "𝒜 e1")
    case None thus ?thesis using Seq by simp
  next
    case (Some A1)
    have indexA1: "𝒜 (compE1 Vs e1) = index Vs ` A1"
      using A_compE1[OF Some] Seq.prems  by auto
    have "A  A1  set Vs" using Seq.prems A_fv[OF Some] by auto
    hence "𝒟 (compE1 Vs e2) index Vs ` (A  A1)" using Seq Some by auto
    hence "𝒟 (compE1 Vs e2) index Vs ` A  index Vs ` A1"
      by(simp add: image_Un)
    thus ?thesis using IH1 indexA1 by auto
  qed
next
  case (Cond e e1 e2)
  hence IH1: "𝒟 (compE1 Vs e) index Vs ` A" by simp
  show ?case
  proof (cases "𝒜 e")
    case None thus ?thesis using Cond by simp
  next
    case (Some B)
    have indexB: "𝒜 (compE1 Vs e) = index Vs ` B"
      using A_compE1[OF Some] Cond.prems  by auto
    have "A  B  set Vs" using Cond.prems A_fv[OF Some] by auto
    hence "𝒟 (compE1 Vs e1) index Vs ` (A  B)"
      and "𝒟 (compE1 Vs e2) index Vs ` (A  B)"
      using Cond Some by auto
    hence "𝒟 (compE1 Vs e1) index Vs ` A  index Vs ` B"
      and "𝒟 (compE1 Vs e2) index Vs ` A  index Vs ` B"
      by(simp add: image_Un)+
    thus ?thesis using IH1 indexB by auto
  qed
next
  case (While e1 e2)
  hence IH1: "𝒟 (compE1 Vs e1) index Vs ` A" by simp
  show ?case
  proof (cases "𝒜 e1")
    case None thus ?thesis using While by simp
  next
    case (Some A1)
    have indexA1: "𝒜 (compE1 Vs e1) = index Vs ` A1"
      using A_compE1[OF Some] While.prems  by auto
    have "A  A1  set Vs" using While.prems A_fv[OF Some] by auto
    hence "𝒟 (compE1 Vs e2) index Vs ` (A  A1)" using While Some by auto
    hence "𝒟 (compE1 Vs e2) index Vs ` A  index Vs ` A1"
      by(simp add: image_Un)
    thus ?thesis using IH1 indexA1 by auto
  qed
next
  case (Block V T vo e A Vs)
  have IH: "A Vs. A  set Vs; fv e  set Vs; 𝒟 e A  𝒟 (compE1 Vs e) index Vs ` A" by fact
  from ‹fv {V:T=vo; e}  set Vs have fv: "fv e  set (Vs @ [V])" by auto
  show ?case
  proof(cases vo)
    case None
    with ‹𝒟 {V:T=vo; e} A have D: "𝒟 e A - {V}" by(auto)
    from A  set Vs have "A - {V}  set (Vs @ [V])" by auto
    from IH[OF this fv D] have "𝒟 (compE1 (Vs @ [V]) e) index (Vs @ [V]) ` (A - {V})" .
    moreover from A  set Vs have size: "size Vs  index Vs ` A" by(auto simp add: image_def)
    hence "index Vs ` (A - {V})  index Vs ` A" by(auto simp add: hyperset_defs)
    ultimately have "𝒟 (compE1 (Vs @ [V]) e) index Vs ` A" using A - {V}  set (Vs @ [V])
      by(simp add: image_index)(erule D_mono', auto)
    thus ?thesis using None size by(simp)
  next
    case (Some v)
    with ‹𝒟 {V:T=vo; e} A have D: "𝒟 e insert V A" by(auto)
    from A  set Vs have "insert V A  set (Vs @ [V])" by auto
    from IH[OF this fv D] have "𝒟 (compE1 (Vs @ [V]) e) index (Vs @ [V]) ` insert V A" by simp
    moreover from A  set Vs have "index (Vs @ [V]) ` insert V A  insert (length Vs) (index Vs ` A)"
      by(auto simp add: image_index)
    ultimately show ?thesis using Some by(auto elim!: D_mono' simp add: hyperset_defs)
  qed
next
  case (Cons_exp e1 es)
  hence IH1: "𝒟 (compE1 Vs e1) index Vs ` A" by simp
  show ?case
  proof (cases "𝒜 e1")
    case None thus ?thesis using Cons_exp by simp
  next
    case (Some A1)
    have indexA1: "𝒜 (compE1 Vs e1) = index Vs ` A1"
      using A_compE1[OF Some] Cons_exp.prems  by auto
    have "A  A1  set Vs" using Cons_exp.prems A_fv[OF Some] by auto
    hence "𝒟s (compEs1 Vs es) index Vs ` (A  A1)" using Cons_exp Some by auto
    hence "𝒟s (compEs1 Vs es) index Vs ` A  index Vs ` A1"
      by(simp add: image_Un)
    thus ?thesis using IH1 indexA1 by auto
  qed
qed (simp_all add:hyperset_defs)

declare Un_ac [simp del]

lemma index_image_set: "distinct xs  index xs ` set xs = {..<size xs}"
by(induct xs rule:rev_induct) (auto simp add: image_index)

lemma D_compE1:
  " 𝒟 e set Vs; fv e  set Vs; distinct Vs   𝒟 (compE1 Vs e) {..<length Vs}"
by(fastforce dest!: D_index_compE1[OF subset_refl] simp add:index_image_set)

lemma D_compE1':
  assumes "𝒟 e set(V#Vs)" and "fv e  set(V#Vs)" and "distinct(V#Vs)"
  shows "𝒟 (compE1 (V#Vs) e) {..length Vs}"
proof -
  have "{..size Vs} = {..<size(V#Vs)}" by auto
  thus ?thesis using assms by (simp only:)(rule D_compE1)
qed

lemma compP1_pres_wf: "wf_J_prog P  wf_J1_prog (compP1 P)"
apply simp
apply(rule wf_prog_compPI)
 prefer 2 apply assumption
apply(case_tac m)
apply(simp add:wf_mdecl_def)
apply(clarify)
apply(frule WT_fv)
apply(fastforce intro!: compE1_pres_wt D_compE1' ℬ syncvars_compE1)
done

end

Theory Compiler

theory Compiler imports Compiler1 Compiler2 begin

definition J2JVM :: "'addr J_prog  'addr jvm_prog"
where [code del]: "J2JVM  compP2  compP1"

lemma J2JVM_code [code]:
  "J2JVM = compP (λC M Ts T (pns, body). compMb2 (compE1 (this#pns) body))"
by(simp add: J2JVM_def compP2_def o_def compP_compP split_def)

end

Theory Correctness

(*  Title:      JinjaThreads/Compiler/Correctness.thy
    Author:     Andreas Lochbihler
*)

section ‹Correctness of both stages›

theory Correctness 
imports
  J0Bisim
  J1Deadlock 
  "../Framework/FWBisimDeadlock"
  Correctness2
  Correctness1Threaded
  Correctness1 
  JJ1WellForm
  Compiler
begin

locale J_JVM_heap_conf_base = 
  J0_J1_heap_base
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write 
  +
  J1_JVM_heap_conf_base 
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write 
    hconf "compP1 P"
  for addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and hconf :: "'heap  bool"
  and P :: "'addr J_prog"
begin

definition bisimJ2JVM :: 
  "(('addr,'thread_id,'addr expr×'addr locals,'heap,'addr) state, 
    ('addr,'thread_id,'addr option × 'addr frame list,'heap,'addr) state) bisim"
where "bisimJ2JVM = red_red0.mbisim B red0_Red1'.mbisim B mbisim_Red1'_Red1 B Red1_execd.mbisim"

definition tlsimJ2JVM ::
  "('thread_id × ('addr, 'thread_id, 'heap) J_thread_action,
    'thread_id × ('addr, 'thread_id, 'heap) jvm_thread_action) bisim"
where "tlsimJ2JVM = red_red0.mta_bisim B red0_Red1'.mta_bisim B (=) B Red1_execd.mta_bisim"

end

lemma compP2_has_method [simp]: "compP2 P  C has M  P  C has M"
by(auto simp add: compP2_def compP_has_method)

locale J_JVM_conf_read = 
  J1_JVM_conf_read
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write 
    hconf "compP1 P"
  for addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and hconf :: "'heap  bool"
  and P :: "'addr J_prog"
begin

sublocale J_JVM_heap_conf_base by(unfold_locales)

theorem bisimJ2JVM_weak_bisim:
  assumes wf: "wf_J_prog P"
  shows "delay_bisimulation_diverge_final (mredT P) (execd_mthr.redT (J2JVM P)) bisimJ2JVM tlsimJ2JVM 
            (red_mthr.mτmove P) (execd_mthr.mτmove (J2JVM P)) red_mthr.mfinal exec_mthr.mfinal"
unfolding bisimJ2JVM_def tlsimJ2JVM_def J2JVM_def o_apply
apply(rule delay_bisimulation_diverge_final_compose)
 apply(rule FWdelay_bisimulation_diverge.mthr_delay_bisimulation_diverge_final)
 apply(rule red_red0_FWbisim[OF wf_prog_wwf_prog[OF wf]])
apply(rule delay_bisimulation_diverge_final_compose)
 apply(rule FWdelay_bisimulation_diverge.mthr_delay_bisimulation_diverge_final)
 apply(rule red0_Red1'_FWweak_bisim[OF wf])
apply(rule delay_bisimulation_diverge_final_compose)
 apply(rule delay_bisimulation_diverge_final.intro)
  apply(rule bisimulation_into_delay.delay_bisimulation)
  apply(rule Red1'_Red1_bisim_into_weak[OF compP1_pres_wf[OF wf]])
 apply(rule bisimulation_final.delay_bisimulation_final_base)
 apply(rule Red1'_Red1_bisimulation_final[OF compP1_pres_wf[OF wf]])
apply(rule FWdelay_bisimulation_diverge.mthr_delay_bisimulation_diverge_final)
apply(rule Red1_exec1_FWwbisim[OF compP1_pres_wf[OF wf]])
done


lemma bisimJ2JVM_start:
  assumes wf: "wf_J_prog P"
  and start: "wf_start_state P C M vs"
  shows "bisimJ2JVM (J_start_state P C M vs) (JVM_start_state (J2JVM P) C M vs)"
using assms
unfolding bisimJ2JVM_def J2JVM_def o_def
apply(intro bisim_composeI)
   apply(erule (1) bisim_J_J0_start[OF wf_prog_wwf_prog])
  apply(erule (1) bisim_J0_J1_start)
 apply(erule bisim_J1_J1_start[OF compP1_pres_wf])
 apply simp
apply(erule bisim_J1_JVM_start[OF compP1_pres_wf])
apply simp
done

end

fun exception :: "'addr expr × 'addr locals  'addr option × 'addr frame list"
where "exception (Throw a, xs) = (a, [])"
| "exception _ = (None, [])"

definition mexception :: 
  "('addr,'thread_id,'addr expr×'addr locals,'heap,'addr) state  
   ('addr,'thread_id,'addr option×'addr frame list,'heap,'addr) state"
where
  "ln. mexception s  
  (locks s, (λt. case thr s t of (e, ln)  (exception e, ln) | None  None, shr s), wset s, interrupts s)"

declare compP1_def [simp del]

context J_JVM_heap_conf_base begin

lemma bisimJ2JVM_mfinal_mexception:
  assumes bisim: "bisimJ2JVM s s'"
  and fin: "exec_mthr.mfinal s'"
  and fin': "red_mthr.mfinal s"
  and tsNotEmpty: "thr s t  None"
  shows "s' = mexception s"
proof -
  obtain ls ts m ws "is" where s: "s = (ls, (ts, m), ws, is)" by(cases s) fastforce
  from bisim obtain s0 s1 where bisimJ0: "red_red0.mbisim s s0"
    and bisim01: "red0_Red1'.mbisim s0 s1"
    and bisim1JVM: "Red1_execd.mbisim s1 s'"
    unfolding bisimJ2JVM_def by(fastforce simp add: mbisim_Red1'_Red1_def)
  from bisimJ0 s have [simp]: "locks s0 = ls" "wset s0 = ws" "interrupts s0 = is"
    and tbisimJ0: "t. red_red0.tbisim (ws t = None) t (ts t) m (thr s0 t) (shr s0)"
    by(auto simp add: red_red0.mbisim_def)
  from bisim01 have [simp]: "locks s1 = ls" "wset s1 = ws" "interrupts s1 = is"
    and tbisim01: "t. red0_Red1'.tbisim (ws t = None) t (thr s0 t) (shr s0) (thr s1 t) (shr s1)"
    by(auto simp add: red0_Red1'.mbisim_def)
  from bisim1JVM have "locks s' = ls" "wset s' = ws" "interrupts s' = is"
    and tbisim1JVM: "t. Red1_execd.tbisim (ws t = None) t (thr s1 t) (shr s1) (thr s' t) (shr s')"
    by(auto simp add: Red1_execd.mbisim_def)
  then obtain ts' m' where s': "s' = (ls, (ts', m'), ws, is)" by(cases s') fastforce
  { fix t e x ln
    assume tst: "ts t = ((e, x), ln)"
    from tbisimJ0[of t] tst obtain e' exs' where ts0t: "thr s0 t = ((e', exs'), ln)"
      and bisimtJ0: "bisim_red_red0 ((e, x), m) ((e', exs'), shr s0)"
      by(auto simp add: red_red0.tbisim_def)
    from tbisim01[of t] ts0t obtain e'' xs'' exs''
      where ts1t: "thr s1 t = (((e'', xs''), exs''), ln)"
      and bisimt01: "bisim_red0_Red1 ((e', exs'), shr s0) (((e'', xs''), exs''), shr s1)"
      by(auto simp add: red0_Red1'.tbisim_def)
    from tbisim1JVM[of t] ts1t s' obtain xcp frs
      where ts't: "ts' t = ((xcp, frs), ln)" and [simp]: "m' = shr s1"
      and bisimt1JVM: "bisim1_list1 t m' (e'', xs'') exs'' xcp frs"
      by(fastforce simp add: Red1_execd.tbisim_def)

    from fin ts't s s' have [simp]: "frs = []" by(auto dest: exec_mthr.mfinalD)
    from bisimt1JVM have [simp]: "exs'' = []" by(auto elim: bisim1_list1.cases)
    from bisimt01 have [simp]: "exs' = []"
      by(auto simp add: bisim_red0_Red1_def elim!: bisim_list1E elim: bisim_list.cases)
    from tst fin' s have fine: "final e" by(auto dest: red_mthr.mfinalD)
    hence "exception (e, x) = (xcp, frs)"
    proof(cases)
      fix v
      assume [simp]: "e = Val v"
      from bisimtJ0 have "e' = Val v" by(auto elim!: bisim_red_red0.cases)
      with bisimt01 have "e'' = Val v" by(auto simp add: bisim_red0_Red1_def elim: bisim_list1E)
      with bisimt1JVM have "xcp = None" by(auto elim: bisim1_list1.cases)
      thus ?thesis by simp
    next
      fix a
      assume [simp]: "e = Throw a"
      from bisimtJ0 have "e' = Throw a" by(auto elim!: bisim_red_red0.cases)
      with bisimt01 have "e'' = Throw a" by(auto simp add: bisim_red0_Red1_def elim: bisim_list1E)
      with bisimt1JVM have "xcp = a" by(auto elim: bisim1_list1.cases)
      thus ?thesis by simp
    qed
    moreover from bisimtJ0 have "shr s0 = m" by(auto elim: bisim_red_red0.cases)
    moreover from bisimt01 have "shr s1 = shr s0" by(auto simp add: bisim_red0_Red1_def)
    ultimately have "ts' t = (exception (e, x), ln)" "m' = m" using ts't by simp_all }
  moreover {
    fix t
    assume "ts t = None"
    with red_red0.mbisim_thrNone_eq[OF bisimJ0, of t] s have "thr s0 t = None" by simp
    with bisim01 have "thr s1 t = None" by(auto simp add: red0_Red1'.mbisim_thrNone_eq)
    with bisim1JVM s' have "ts' t = None" by(simp add: Red1_execd.mbisim_thrNone_eq) }
  ultimately show ?thesis using s s' tsNotEmpty by(auto simp add: mexception_def fun_eq_iff)
qed

end

context J_JVM_conf_read begin

theorem J2JVM_correct1:
  fixes C M vs
  defines s: "s  J_start_state P C M vs"
  and comps: "cs  JVM_start_state (J2JVM P) C M vs"
  assumes wf: "wf_J_prog P"
  and wf_start: "wf_start_state P C M vs"
  and red: "red_mthr.mthr.τRuns P s ξ"
  obtains ξ' 
  where "execd_mthr.mthr.τRuns (J2JVM P) cs ξ'" "tllist_all2 tlsimJ2JVM (rel_option bisimJ2JVM) ξ ξ'"
  and "s'.  tfinite ξ; terminal ξ = s'; red_mthr.mfinal s' 
       tfinite ξ'  terminal ξ' = mexception s'"
  and "s'.  tfinite ξ; terminal ξ = s'; red_mthr.deadlock P s' 
       cs'. tfinite ξ'  terminal ξ' = cs'  execd_mthr.deadlock (J2JVM P) cs'  bisimJ2JVM s' cs'"
  and " tfinite ξ; terminal ξ = None   tfinite ξ'  terminal ξ' = None"
  and "¬ tfinite ξ  ¬ tfinite ξ'"
proof -
  from wf wf_start have bisim: "bisimJ2JVM s cs" unfolding s comps by(rule bisimJ2JVM_start)

  note divfin = delay_bisimulation_diverge_final.delay_bisimulation_diverge[OF bisimJ2JVM_weak_bisim[OF wf]]
  note divfin2 = delay_bisimulation_diverge_final.delay_bisimulation_final_base[OF bisimJ2JVM_weak_bisim[OF wf]]

  from delay_bisimulation_diverge.simulation_τRuns1[OF divfin, OF bisim red] obtain ξ' 
    where exec: "execd_mthr.mthr.τRuns (J2JVM P) cs ξ'" 
    and tlsim: "tllist_all2 tlsimJ2JVM (rel_option bisimJ2JVM) ξ ξ'" by blast
  moreover {
    fix s'
    assume fin: "tfinite ξ" and s': "terminal ξ = s'" and final: "red_mthr.mfinal s'"
    from delay_bisimulation_final_base.τRuns_terminate_final1[OF divfin2, OF red exec tlsim fin s' final]
    obtain cs' where fin': "tfinite ξ'" and cs': "terminal ξ' = cs'"
      and final': "exec_mthr.mfinal cs'" by blast
    from tlsim fin s' cs' have bisim': "bisimJ2JVM s' cs'" by(auto dest: tllist_all2_tfinite1_terminalD)
    from red_mthr.mthr.τRuns_into_τrtrancl3p[OF red fin s'] 
    have "thr s' start_tid  None" unfolding s
      by(rule red_mthr.τrtrancl3p_redT_thread_not_disappear)(simp add: start_state_def)
    with bisim' final final' have [simp]: "cs' = mexception s'"
      by(intro bisimJ2JVM_mfinal_mexception disjI1)
    with fin' cs' have "tfinite ξ'  terminal ξ' = mexception s'" by simp }
  moreover {
    fix s'
    assume fin: "tfinite ξ" and s': "terminal ξ = s'" and dead: "red_mthr.deadlock P s'"
    from tlsim fin s'
    obtain cs' where "tfinite ξ'" and cs': "terminal ξ' = cs'"
      and bisim': "bisimJ2JVM s' cs'"
      by(cases "terminal ξ'")(fastforce dest: tllist_all2_tfinite1_terminalD tllist_all2_tfiniteD)+
    from bisim' obtain s0' s1' S1' where bisim0: "red_red0.mbisim s' s0'"
      and bisim01: "red0_Red1'.mbisim s0' s1'"
      and bisim11: "mbisim_Red1'_Red1 s1' S1'"
      and bisim12: "Red1_execd.mbisim S1' cs'"
      unfolding bisimJ2JVM_def by auto

    note b0 = red_red0_FWbisim[OF wf_prog_wwf_prog[OF wf]]
    note b01 = red0_Red1'_FWweak_bisim[OF wf]
    note b01mthr = FWdelay_bisimulation_diverge.mbisim_delay_bisimulation[OF b01]
    note b11 = Red1'_Red1_bisim_into_weak[OF compP1_pres_wf[OF wf]]
    note b11delay = bisimulation_into_delay.delay_bisimulation[OF b11]
    note b12 = Red1_exec1_FWwbisim[OF compP1_pres_wf[OF wf]]
    note b12mthr = FWdelay_bisimulation_diverge.mbisim_delay_bisimulation[OF b12]

    from FWdelay_bisimulation_diverge.deadlock1_imp_τs_deadlock2[OF b0, OF bisim0 dead, of convert_RA]
    obtain s0'' where "red0_mthr.mthr.silent_moves P s0' s0''"
      and bisim0': "red_red0.mbisim s' s0''"
      and dead0: "red0_mthr.deadlock P s0''" by auto
    
    from delay_bisimulation_diverge.simulation_silents1[OF b01mthr, OF bisim01 ‹red0_mthr.mthr.silent_moves P s0' s0'']
    obtain s1'' where "Red1_mthr.mthr.silent_moves False (compP1 P) s1' s1''"
      and "red0_Red1'.mbisim s0'' s1''" by auto
    from FWdelay_bisimulation_diverge.deadlock1_imp_τs_deadlock2[OF b01, OF ‹red0_Red1'.mbisim s0'' s1'' dead0, of convert_RA]
    obtain s1''' where "Red1_mthr.mthr.silent_moves False (compP1 P) s1'' s1'''"
      and dead1: "Red1_mthr.deadlock False (compP1 P) s1'''"
      and bisim01': "red0_Red1'.mbisim s0'' s1'''" by auto
    from ‹Red1_mthr.mthr.silent_moves False (compP1 P) s1' s1'' ‹Red1_mthr.mthr.silent_moves False (compP1 P) s1'' s1'''
    have "Red1_mthr.mthr.silent_moves False (compP1 P) s1' s1'''" by(rule rtranclp_trans)

    from delay_bisimulation_diverge.simulation_silents1[OF b11delay, OF bisim11 this]
    obtain S1'' where "Red1_mthr.mthr.silent_moves True (compP1 P) S1' S1''"
      and bisim11': "mbisim_Red1'_Red1 s1''' S1''" by auto
    from bisim11' have "s1''' = S1''" by(simp add: mbisim_Red1'_Red1_def)
    with dead1 have dead1': "Red1_mthr.deadlock True (compP1 P) S1''"
      by(simp add: Red1_Red1'_deadlock_inv)

    from delay_bisimulation_diverge.simulation_silents1[OF b12mthr, OF bisim12 ‹Red1_mthr.mthr.silent_moves True (compP1 P) S1' S1'']
    obtain cs'' where "execd_mthr.mthr.silent_moves (compP2 (compP1 P)) cs' cs''"
      and "Red1_execd.mbisim S1'' cs''" by auto
    from FWdelay_bisimulation_diverge.deadlock1_imp_τs_deadlock2[OF b12 ‹Red1_execd.mbisim S1'' cs'' dead1', of convert_RA]
    obtain cs''' where "execd_mthr.mthr.silent_moves (compP2 (compP1 P)) cs'' cs'''"
      and bisim12': "Red1_execd.mbisim S1'' cs'''"
      and dead': "execd_mthr.deadlock (compP2 (compP1 P)) cs'''" by auto
    from ‹execd_mthr.mthr.silent_moves (compP2 (compP1 P)) cs' cs'' ‹execd_mthr.mthr.silent_moves (compP2 (compP1 P)) cs'' cs'''
    have "execd_mthr.mthr.silent_moves (compP2 (compP1 P)) cs' cs'''" by(rule rtranclp_trans)
    hence "cs''' = cs'" using execd_mthr.mthr.τRuns_terminal_stuck[OF exec ‹tfinite ξ' ‹terminal ξ' = cs']
      by(cases rule: converse_rtranclpE)(fastforce simp add: J2JVM_def)+
    with dead' have "execd_mthr.deadlock (J2JVM P) cs'" by(simp add: J2JVM_def)
    hence "cs'. tfinite ξ'  terminal ξ' = cs'  execd_mthr.deadlock (J2JVM P) cs'  bisimJ2JVM s' cs'"
      using ‹tfinite ξ' ‹terminal ξ' = cs' bisim' by blast }
  moreover {
    assume "tfinite ξ" and "terminal ξ = None"
    hence "tfinite ξ'  terminal ξ' = None" using tlsim tllist_all2_tfiniteD[OF tlsim]
      by(cases "terminal ξ'")(auto dest: tllist_all2_tfinite1_terminalD) }
  moreover {
    assume "¬ tfinite ξ"
      hence "¬ tfinite ξ'" using tlsim by(blast dest: tllist_all2_tfiniteD) }
  ultimately show thesis by(rule that)
qed

theorem J2JVM_correct2:
  fixes C M vs
  defines s: "s  J_start_state P C M vs"
  and comps: "cs  JVM_start_state (J2JVM P) C M vs"
  assumes wf: "wf_J_prog P"
  and wf_start: "wf_start_state P C M vs"
  and exec: "execd_mthr.mthr.τRuns (J2JVM P) cs ξ'"
  obtains ξ 
  where "red_mthr.mthr.τRuns P s ξ" "tllist_all2 tlsimJ2JVM (rel_option bisimJ2JVM) ξ ξ'"
  and "cs'.  tfinite ξ'; terminal ξ' = cs'; exec_mthr.mfinal cs' 
       s'. tfinite ξ  terminal ξ = s'  cs' = mexception s'  bisimJ2JVM s' cs'"
  and "cs'.  tfinite ξ'; terminal ξ' = cs'; execd_mthr.deadlock (J2JVM P) cs' 
       s'. tfinite ξ  terminal ξ = s'  red_mthr.deadlock P s'  bisimJ2JVM s' cs'"
  and " tfinite ξ'; terminal ξ' = None   tfinite ξ  terminal ξ = None"
  and "¬ tfinite ξ'  ¬ tfinite ξ"
proof -
  from wf wf_start have bisim: "bisimJ2JVM s cs" unfolding s comps by(rule bisimJ2JVM_start)

  note divfin = delay_bisimulation_diverge_final.delay_bisimulation_diverge[OF bisimJ2JVM_weak_bisim[OF wf]]
  note divfin2 = delay_bisimulation_diverge_final.delay_bisimulation_final_base[OF bisimJ2JVM_weak_bisim[OF wf]]

  from delay_bisimulation_diverge.simulation_τRuns2[OF divfin, OF bisim exec] obtain ξ
    where red: "red_mthr.mthr.τRuns P s ξ" 
    and tlsim: "tllist_all2 tlsimJ2JVM (rel_option bisimJ2JVM) ξ ξ'" by blast
  moreover {
    fix cs'
    assume fin: "tfinite ξ'" and cs': "terminal ξ' = cs'" and final: "exec_mthr.mfinal cs'"
    from delay_bisimulation_final_base.τRuns_terminate_final2[OF divfin2, OF red exec tlsim fin cs' final]
    obtain s' where fin': "tfinite ξ" and s': "terminal ξ = s'"
      and final': "red_mthr.mfinal s'" by blast
    from tlsim fin s' cs' have bisim': "bisimJ2JVM s' cs'" by(auto dest: tllist_all2_tfinite2_terminalD)
    from red_mthr.mthr.τRuns_into_τrtrancl3p[OF red fin' s'] 
    have "thr s' start_tid  None" unfolding s
      by(rule red_mthr.τrtrancl3p_redT_thread_not_disappear)(simp add: start_state_def)
    with bisim' final final' have [simp]: "cs' = mexception s'"
      by(intro bisimJ2JVM_mfinal_mexception)
    with fin' s' bisim' have "s'. tfinite ξ  terminal ξ = s'  cs' = mexception s'  bisimJ2JVM s' cs'" by simp }
  moreover {
    fix cs'
    assume fin: "tfinite ξ'" and cs': "terminal ξ' = cs'" and dead': "execd_mthr.deadlock (J2JVM P) cs'"
    from tlsim fin cs'
    obtain s' where "tfinite ξ" and s': "terminal ξ = s'"
      and bisim': "bisimJ2JVM s' cs'"
      by(cases "terminal ξ")(fastforce dest: tllist_all2_tfinite2_terminalD tllist_all2_tfiniteD)+
    from bisim' obtain s0' s1' S1' where bisim0: "red_red0.mbisim s' s0'"
      and bisim01: "red0_Red1'.mbisim s0' s1'"
      and bisim11: "mbisim_Red1'_Red1 s1' S1'"
      and bisim12: "Red1_execd.mbisim S1' cs'"
      unfolding bisimJ2JVM_def by auto

    note b0 = red_red0_FWbisim[OF wf_prog_wwf_prog[OF wf]]
    note b0mthr = FWdelay_bisimulation_diverge.mbisim_delay_bisimulation[OF b0]
    note b01 = red0_Red1'_FWweak_bisim[OF wf]
    note b01mthr = FWdelay_bisimulation_diverge.mbisim_delay_bisimulation[OF b01]
    note b11 = Red1'_Red1_bisim_into_weak[OF compP1_pres_wf[OF wf]]
    note b11delay = bisimulation_into_delay.delay_bisimulation[OF b11]
    note b12 = Red1_exec1_FWwbisim[OF compP1_pres_wf[OF wf]]

    from FWdelay_bisimulation_diverge.deadlock2_imp_τs_deadlock1[OF b12 bisim12, of convert_RA] dead'
    obtain S1'' where "Red1_mthr.mthr.silent_moves True (compP1 P) S1' S1''"
      and bisim12': "Red1_execd.mbisim S1'' cs'"
      and dead': "Red1_mthr.deadlock True (compP1 P) S1''" by(auto simp add: J2JVM_def)
    from delay_bisimulation_diverge.simulation_silents2[OF b11delay, OF bisim11 ‹Red1_mthr.mthr.silent_moves True (compP1 P) S1' S1'']
    obtain s1'' where "Red1_mthr.mthr.silent_moves False (compP1 P) s1' s1''"
      and bisim11': "mbisim_Red1'_Red1 s1'' S1''" by blast
    from bisim11' have "s1'' = S1''" by(simp add: mbisim_Red1'_Red1_def)
    with dead' have dead1: "Red1_mthr.deadlock False (compP1 P) s1''"
      by(simp add: Red1_Red1'_deadlock_inv)
    from delay_bisimulation_diverge.simulation_silents2[OF b01mthr, OF bisim01 ‹Red1_mthr.mthr.silent_moves False (compP1 P) s1' s1'']
    obtain s0'' where "red0_mthr.mthr.silent_moves P s0' s0''"
      and bisim01': "red0_Red1'.mbisim s0'' s1''" by auto
    from FWdelay_bisimulation_diverge.deadlock2_imp_τs_deadlock1[OF b01 bisim01' dead1, of convert_RA]
    obtain s0''' where "red0_mthr.mthr.silent_moves P s0'' s0'''"
      and bisim01'': "red0_Red1'.mbisim s0''' s1''"
      and dead0: "red0_mthr.deadlock P s0'''" by auto
    from ‹red0_mthr.mthr.silent_moves P s0' s0'' ‹red0_mthr.mthr.silent_moves P s0'' s0'''
    have "red0_mthr.mthr.silent_moves P s0' s0'''" by(rule rtranclp_trans)
    from delay_bisimulation_diverge.simulation_silents2[OF b0mthr, OF bisim0 this]
    obtain s'' where "red_mthr.mthr.silent_moves P s' s''" 
      and "red_red0.mbisim s'' s0'''" by blast
    from FWdelay_bisimulation_diverge.deadlock2_imp_τs_deadlock1[OF b0 ‹red_red0.mbisim s'' s0''' dead0, of convert_RA]
    obtain s''' where "red_mthr.mthr.silent_moves P s'' s'''" 
      and "red_red0.mbisim s''' s0'''"
      and dead: "red_mthr.deadlock P s'''" by blast
    from ‹red_mthr.mthr.silent_moves P s' s'' ‹red_mthr.mthr.silent_moves P s'' s'''
    have "red_mthr.mthr.silent_moves P s' s'''" by(rule rtranclp_trans)
    hence "s''' = s'" using red_mthr.mthr.τRuns_terminal_stuck[OF red ‹tfinite ξ ‹terminal ξ = s']
      by(cases rule: converse_rtranclpE) fastforce+
    with dead have "red_mthr.deadlock P s'" by(simp)
    hence "s'. tfinite ξ  terminal ξ = s'  red_mthr.deadlock P s'  bisimJ2JVM s' cs'"
      using ‹tfinite ξ ‹terminal ξ = s' bisim' by blast }
  moreover {
    assume "tfinite ξ'" and "terminal ξ' = None"
    hence "tfinite ξ  terminal ξ = None" using tlsim tllist_all2_tfiniteD[OF tlsim]
      by(cases "terminal ξ")(auto dest: tllist_all2_tfinite2_terminalD) }
  moreover {
    assume "¬ tfinite ξ'"
      hence "¬ tfinite ξ" using tlsim by(blast dest: tllist_all2_tfiniteD) }
  ultimately show thesis by(rule that)
qed

end

declare compP1_def [simp]

theorem wt_J2JVM: "wf_J_prog P  wf_jvm_prog (J2JVM P)"
unfolding J2JVM_def o_def
by(rule wt_compP2)(rule compP1_pres_wf)

end

Theory Preprocessor

theory Preprocessor 
imports 
  PCompiler
  "../J/Annotate"
  "../J/JWellForm"
begin

primrec annotate_Mb ::
  "'addr J_prog  cname  mname  ty list  ty  (vname list × 'addr expr)  (vname list × 'addr expr)"
where "annotate_Mb P C M Ts T (pns, e) = (pns, annotate P [this # pns [↦] Class C # Ts] e)"
declare annotate_Mb.simps [simp del]

primrec annotate_Mb_code :: 
  "'addr J_prog  cname  mname  ty list  ty  (vname list × 'addr expr)  (vname list × 'addr expr)"
where "annotate_Mb_code P C M Ts T (pns, e) = (pns, annotate_code P [this # pns [↦] Class C # Ts] e)"
declare annotate_Mb_code.simps [simp del]

definition annotate_prog :: "'addr J_prog  'addr J_prog"
where "annotate_prog P = compP (annotate_Mb P) P"

definition annotate_prog_code :: "'addr J_prog  'addr J_prog"
where "annotate_prog_code P = compP (annotate_Mb_code P) P"

lemma fixes is_lub
  shows WT_compP: "is_lub,P,E  e :: T  is_lub,compP f P,E  e :: T"
  and WTs_compP: "is_lub,P,E  es [::] Ts  is_lub,compP f P,E  es [::] Ts"
proof(induct rule: WT_WTs.inducts)
  case (WTCall E e U C M Ts T meth D es Ts')
  from P  C sees M: TsT = meth in D
  have "compP f P  C sees M: TsT = map_option (f D M Ts T) meth in D"
    by(auto dest: sees_method_compP[where f=f])
  with WTCall show ?case by(auto)
qed(auto simp del: fun_upd_apply)

lemma fixes is_lub
  shows Anno_compP: "is_lub,P,E  e  e'  is_lub,compP f P,E  e  e'"
  and Annos_compP: "is_lub,P,E  es [↝] es'  is_lub,compP f P,E  es [↝] es'"
apply(induct rule: Anno_Annos.inducts)
apply(auto intro: Anno_Annos.intros simp del: fun_upd_apply dest: WT_compP simp add: compC_def)
done

lemma annotate_prog_code_eq_annotate_prog:
  assumes wf: "wf_J_prog (annotate_prog_code P)"
  shows "annotate_prog_code P = annotate_prog P"
proof -
  let ?wf_md = "λ_ _ (_,_,_,_,body). set (block_types body)  types P"
  from wf have "wf_prog ?wf_md (annotate_prog_code P)"
    unfolding annotate_prog_code_def
    by(rule wf_prog_lift)(auto dest!: WT_block_types_is_type[OF wf[unfolded annotate_prog_code_def]] simp add: wf_J_mdecl_def)
  hence wf': "wf_prog ?wf_md P"
    unfolding annotate_prog_code_def [abs_def]
  proof(rule wf_prog_compPD)
    fix C M Ts T m
    assume "compP (annotate_Mb_code P) P  C sees M: TsT = annotate_Mb_code P C M Ts T m in C"
      and "wf_mdecl ?wf_md (compP (annotate_Mb_code P) P) C (M, Ts, T, annotate_Mb_code P C M Ts T m)"
    moreover obtain pns body where "m = (pns, body)" by(cases m)
    ultimately show "wf_mdecl ?wf_md P C (M, Ts, T, m)"
      by(fastforce simp add: annotate_Mb_code_def annotate_code_def wf_mdecl_def THE_default_def the_equality Anno_code_def split: if_split_asm dest: Anno_block_types)
  qed

  { fix C D fs ms M Ts T pns body
    assume "(C, D, fs, ms)  set (classes P)"
      and "(M, Ts, T, (pns, body))  set ms"
    from (C, D, fs, ms)  set (classes P) have "class P C = (D, fs, ms)" using wf'
      by(cases P)(auto simp add: wf_prog_def dest: map_of_SomeI)
    with wf' have sees: "P  C sees M:TsT = (pns, body) in C"
      using (M, Ts, T, (pns, body))  set ms by(rule mdecl_visible)

    from sees_method_compP[OF this, where f="annotate_Mb_code P"]
    have sees': "annotate_prog_code P  C sees M:TsT = (pns, annotate_code P [this  Class C, pns [↦] Ts] body) in C"
      unfolding annotate_prog_code_def annotate_Mb_code_def by(auto)
    with wf
    have "wf_mdecl wf_J_mdecl (annotate_prog_code P) C (M, Ts, T, (pns, annotate_code P [this  Class C, pns [↦] Ts] body))"
      by(rule sees_wf_mdecl)
    hence "set Ts  types P" by(auto simp add: wf_mdecl_def annotate_prog_code_def)
    moreover from sees have "is_class P C" by(rule sees_method_is_class)
    moreover from wf' sees have "wf_mdecl ?wf_md P C (M, Ts, T, (pns, body))" by(rule sees_wf_mdecl)
    hence "set (block_types body)  types P" by(simp add: wf_mdecl_def)
    ultimately have "ran [this  Class C, pns [↦] Ts]  set (block_types body)  types P"
      by(auto simp add: ran_def wf_mdecl_def map_upds_def split: if_split_asm dest!: map_of_SomeD set_zip_rightD)
    hence "annotate_code P [this  Class C, pns [↦] Ts] body = annotate P [this  Class C, pns [↦] Ts] body"
      unfolding annotate_code_def annotate_def
      by -(rule arg_cong[where f="THE_default body"], auto intro!: ext intro: Anno_code_into_Anno[OF wf'] Anno_into_Anno_code[OF wf']) }
  thus ?thesis unfolding annotate_prog_code_def annotate_prog_def
    by(cases P)(auto simp add: compC_def compM_def annotate_Mb_def annotate_Mb_code_def map_option_case)
qed

end

Theory Compiler_Main

theory Compiler_Main
imports
  J0
  Correctness
  Preprocessor
begin

end

Theory MM

(*  Title:      JinjaThreads/MM/MM.thy
    Author:     Andreas Lochbihler
*)

chapter ‹Memory Models›

theory MM
imports
  "../Common/Heap"
begin

type_synonym addr = nat
type_synonym thread_id = addr

abbreviation (input) 
  addr2thread_id :: "addr  thread_id"
where "addr2thread_id  λx. x"

abbreviation (input)
  thread_id2addr :: "thread_id  addr"
where "thread_id2addr  λx. x"

instantiation nat :: addr begin
definition "hash_addr  int"
definition "monitor_finfun_to_list  (finfun_to_list :: nat ⇒f nat  nat list)"
instance
by(intro_classes)(simp add: monitor_finfun_to_list_nat_def)
end

definition new_Addr :: "(addr  'b)  addr option"
where "new_Addr h  if a. h a = None then Some(LEAST a. h a = None) else None"

lemma new_Addr_SomeD:
  "new_Addr h = Some a  h a = None"
by(auto simp add:new_Addr_def split:if_splits intro: LeastI)

lemma new_Addr_SomeI:
  "finite (dom h)  a. new_Addr h = Some a"
by(simp add: new_Addr_def) (metis finite_map_freshness infinite_UNIV_nat)

subsection ‹Code generation›

definition gen_new_Addr :: "(addr  'b)  addr  addr option"
where "gen_new_Addr h n  if a. a  n  h a = None then Some(LEAST a. a  n  h a = None) else None"

lemma new_Addr_code_code [code]:
  "new_Addr h = gen_new_Addr h 0"
by(simp add: new_Addr_def gen_new_Addr_def)

lemma gen_new_Addr_code [code]:
  "gen_new_Addr h n = (if h n = None then Some n else gen_new_Addr h (Suc n))"
apply(simp add: gen_new_Addr_def)
apply(rule impI)
apply(rule conjI)
 apply safe[1]
  apply(auto intro: Least_equality)[2]
 apply(rule arg_cong[where f=Least])
 apply(rule ext)
 apply auto[1]
 apply(case_tac "n = ab")
  apply simp
 apply simp
apply clarify
apply(subgoal_tac "a = n")
 apply simp
 apply(rule Least_equality)
 apply auto[2]
apply(rule ccontr)
apply(erule_tac x="a" in allE)
apply simp
done

end

Theory SC

(*  Title:      JinjaThreads/MM/SC.thy
    Author:     David von Oheimb, Andreas Lochbihler

    Based on the Jinja theories Common/Objects.thy and Common/Conform by David von Oheimb
*)

section ‹Sequential consistency›

theory SC
imports 
  "../Common/Conform"
  MM
begin

subsection‹Objects and Arrays›

type_synonym 
  fields = "vname × cname  addr val"       ― ‹field name, defining class, value›

type_synonym
  cells = "addr val list"

datatype heapobj
  = Obj cname fields
    ― ‹class instance with class name and fields›

  | Arr ty fields cells
    ― ‹element type, fields (from object), and list of each cell's content›

lemma rec_heapobj [simp]: "rec_heapobj = case_heapobj"
by(auto intro!: ext split: heapobj.split)

primrec obj_ty  :: "heapobj  htype"
where
  "obj_ty (Obj C f)     = Class_type C"
| "obj_ty (Arr T fs cs) = Array_type T (length cs)"

fun is_Arr :: "heapobj  bool" where
  "is_Arr (Obj C fs)   = False"
| "is_Arr (Arr T f el) = True"

lemma is_Arr_conv:
  "is_Arr arrobj = (T f el. arrobj = Arr T f el)"
by(cases arrobj, auto)

lemma is_ArrE:
  " is_Arr arrobj; T f el. arrobj = Arr T f el  thesis   thesis"
  " ¬ is_Arr arrobj; C fs. arrobj = Obj C fs  thesis   thesis"
by(cases arrobj, auto)+

definition init_fields :: "('field_name × (ty × fmod)) list  'field_name  addr val"
where "init_fields  map_of  map (λ(FD,(T, fm)). (FD,default_val T))"

primrec
  ― ‹a new, blank object with default values in all fields:›
  blank :: "'m prog  htype  heapobj"
where
  "blank P (Class_type C)   = Obj C (init_fields (fields P C))"
| "blank P (Array_type T n) = Arr T (init_fields (fields P Object)) (replicate n (default_val T))"

lemma obj_ty_blank [iff]: 
  "obj_ty (blank P hT) = hT"
by(cases hT)(simp_all)


subsection‹Heap›

type_synonym heap = "addr  heapobj"

translations
  (type) "heap" <= (type) "nat  heapobj option"

abbreviation sc_empty :: heap
where "sc_empty  Map.empty"

fun the_obj :: "heapobj  cname × fields" where
  "the_obj (Obj C fs) = (C, fs)"

fun the_arr :: "heapobj  ty × fields × cells" where
  "the_arr (Arr T f el) = (T, f, el)"

abbreviation
  cname_of :: "heap  addr  cname" where
  "cname_of hp a == fst (the_obj (the (hp a)))"

definition sc_allocate :: "'m prog  heap  htype  (heap × addr) set"
where
  "sc_allocate P h hT = 
   (case new_Addr h of None  {}
                   | Some a  {(h(a  blank P hT), a)})"

definition sc_typeof_addr :: "heap  addr  htype option"
where "sc_typeof_addr h a = map_option obj_ty (h a)"

inductive sc_heap_read :: "heap  addr  addr_loc  addr val  bool"
for h :: heap and a :: addr
where
  Obj: " h a = Obj C fs; fs (F, D) = v   sc_heap_read h a (CField D F) v"
| Arr: " h a = Arr T f el; n < length el   sc_heap_read h a (ACell n) (el ! n)"
| ArrObj: " h a = Arr T f el; f (F, Object) = v   sc_heap_read h a (CField Object F) v"

hide_fact (open) Obj Arr ArrObj

inductive_cases sc_heap_read_cases [elim!]:
  "sc_heap_read h a (CField C F) v"
  "sc_heap_read h a (ACell n) v"

inductive sc_heap_write :: "heap  addr  addr_loc  addr val  heap  bool"
for h :: heap and a :: addr
where
  Obj: " h a = Obj C fs; h' = h(a  Obj C (fs((F, D)  v)))   sc_heap_write h a (CField D F) v h'"
| Arr: " h a = Arr T f el; h' = h(a  Arr T f (el[n := v]))   sc_heap_write h a (ACell n) v h'"
| ArrObj: " h a = Arr T f el; h' = h(a  Arr T (f((F, Object)  v)) el)   sc_heap_write h a (CField Object F) v h'"

hide_fact (open) Obj Arr ArrObj

inductive_cases sc_heap_write_cases [elim!]:
  "sc_heap_write h a (CField C F) v h'"
  "sc_heap_write h a (ACell n) v h'"

consts sc_spurious_wakeups :: bool

interpretation sc: 
  heap_base
    "addr2thread_id"
    "thread_id2addr"
    "sc_spurious_wakeups"
    "sc_empty"
    "sc_allocate P"
    "sc_typeof_addr"
    "sc_heap_read"
    "sc_heap_write"
  for P .

text ‹Translate notation from heap_base›

(* FIXME! Why does sc.preallocated need the type token?? *)
abbreviation sc_preallocated :: "'m prog  heap  bool"
where "sc_preallocated == sc.preallocated TYPE('m)"

abbreviation sc_start_tid :: "'md prog  thread_id"
where "sc_start_tid  sc.start_tid TYPE('md)"

abbreviation sc_start_heap_ok :: "'m prog  bool"
where "sc_start_heap_ok  sc.start_heap_ok TYPE('m)"

abbreviation sc_start_heap :: "'m prog  heap"
where "sc_start_heap  sc.start_heap TYPE('m)"

abbreviation sc_start_state :: 
  "(cname  mname  ty list  ty  'm  addr val list  'x)
   'm prog  cname  mname  addr val list  (addr, thread_id, 'x, heap, addr) state"
where
  "sc_start_state f P  sc.start_state TYPE('m) P f P"

abbreviation sc_wf_start_state :: "'m prog  cname  mname  addr val list  bool"
where "sc_wf_start_state P  sc.wf_start_state TYPE('m) P P"

notation sc.conf ("_,_ ⊢sc _ :≤ _"  [51,51,51,51] 50)
notation sc.confs ("_,_ ⊢sc _ [:≤] _" [51,51,51,51] 50)
notation sc.hext ("_ ⊴sc _" [51,51] 50)

lemma sc_start_heap_ok: "sc_start_heap_ok P"
apply(simp add: sc.start_heap_ok_def sc.start_heap_data_def initialization_list_def sc.create_initial_object_simps sc_allocate_def sys_xcpts_list_def case_option_conv_if new_Addr_SomeI del: blank.simps split del: option.split if_split)
done

lemma sc_wf_start_state_iff:
  "sc_wf_start_state P C M vs  (Ts T meth D. P  C sees M:TsT = meth in D  P,sc_start_heap P ⊢sc vs [:≤] Ts)"
by(simp add: sc.wf_start_state.simps sc_start_heap_ok)

lemma sc_heap:
  "heap addr2thread_id thread_id2addr (sc_allocate P) sc_typeof_addr sc_heap_write P"
proof
  fix h' a h hT
  assume "(h', a)  sc_allocate P h hT"
  thus "sc_typeof_addr h' a = hT"
    by(auto simp add: sc_allocate_def sc_typeof_addr_def dest: new_Addr_SomeD split: if_split_asm)
next
  fix h' h hT a
  assume "(h', a)  sc_allocate P h hT"
  from this[symmetric] show "h ⊴sc h'"
    by(fastforce simp add: sc_allocate_def sc_typeof_addr_def sc.hext_def dest: new_Addr_SomeD intro!: map_leI)
next
  fix h a al v h'
  assume "sc_heap_write h a al v h'"
  thus "h ⊴sc h'"
    by(cases al)(auto intro!: sc.hextI simp add: sc_typeof_addr_def)
qed simp

interpretation sc: 
  heap 
    "addr2thread_id"
    "thread_id2addr"
    "sc_spurious_wakeups"
    "sc_empty"
    "sc_allocate P"
    "sc_typeof_addr"
    "sc_heap_read"
    "sc_heap_write"
  for P by(rule sc_heap)

lemma sc_hext_new:
  "h a = None  h ⊴sc h(a  arrobj)"
by(rule sc.hextI)(auto simp add: sc_typeof_addr_def dest!: new_Addr_SomeD)

lemma sc_hext_upd_obj: "h a = Some (Obj C fs)  h ⊴sc h(a(Obj C fs'))"
by(rule sc.hextI)(auto simp:fun_upd_apply sc_typeof_addr_def)

lemma sc_hext_upd_arr: " h a = Some (Arr T f e); length e = length e'   h ⊴sc h(a(Arr T f' e'))"
by(rule sc.hextI)(auto simp:fun_upd_apply sc_typeof_addr_def)

subsection ‹Conformance›

definition sc_fconf :: "'m prog  cname  heap  fields  bool" ("_,_,_ ⊢sc _ " [51,51,51,51] 50)
where "P,C,h ⊢sc fs  = (F D T fm. P  C has F:T (fm) in D  (v. fs(F,D) = Some v  P,h ⊢sc v :≤ T))"

primrec sc_oconf :: "'m prog  heap  heapobj  bool"   ("_,_ ⊢sc _ " [51,51,51] 50)
where
  "P,h ⊢sc Obj C fs   is_class P C  P,C,h ⊢sc fs "
| "P,h ⊢sc Arr T fs el   is_type P (T⌊⌉)  P,Object,h ⊢sc fs   (v  set el. P,h ⊢sc v :≤ T)"

definition sc_hconf :: "'m prog  heap  bool"  ("_ ⊢sc _ " [51,51] 50)
where "P ⊢sc h   (a obj. h a = Some obj  P,h ⊢sc obj )"

interpretation sc: heap_conf_base  
  "addr2thread_id"
  "thread_id2addr"
  "sc_spurious_wakeups"
  "sc_empty"
  "sc_allocate P"
  "sc_typeof_addr"
  "sc_heap_read"
  "sc_heap_write"
  "sc_hconf P"
  "P"
for P .

declare sc.typeof_addr_thread_id2_addr_addr2thread_id [simp del]

lemma sc_conf_upd_obj: "h a = Some(Obj C fs)  (P,h(a(Obj C fs')) ⊢sc x :≤ T) = (P,h ⊢sc x :≤ T)"
apply (unfold sc.conf_def)
apply (rule val.induct)
apply (auto simp:fun_upd_apply)
apply (auto simp add: sc_typeof_addr_def split: if_split_asm)
done

lemma sc_conf_upd_arr: "h a = Some(Arr T f el)  (P,h(a(Arr T f' el')) ⊢sc x :≤ T') = (P,h ⊢sc x :≤ T')"
apply(unfold sc.conf_def)
apply (rule val.induct)
apply (auto simp:fun_upd_apply)
apply(auto simp add: sc_typeof_addr_def split: if_split_asm)
done

lemma sc_oconf_hext: "P,h ⊢sc obj   h ⊴sc h'  P,h' ⊢sc obj "
by(cases obj)(fastforce elim: sc.conf_hext simp add: sc_fconf_def)+

lemma sc_oconf_init_fields:
  assumes "P  C has_fields FDTs"
  shows "P,h ⊢sc (Obj C (init_fields FDTs)) "
using assms has_fields_is_class[OF assms]
by(auto simp add: has_field_def init_fields_def sc_fconf_def split_def o_def map_of_map[simplified split_def, where f="λp. default_val (fst p)"] dest: has_fields_fun)

lemma sc_oconf_init:
 "is_htype P hT  P,h ⊢sc blank P hT "
by(cases hT)(auto simp add: sc_fconf_def has_field_def init_fields_def split_def o_def map_of_map[simplified split_def, where f="λp. default_val (fst p)"] dest: has_fields_fun)

lemma sc_oconf_fupd [intro?]:
  " P  C has F:T (fm) in D; P,h ⊢sc v :≤ T; P,h ⊢sc (Obj C fs)   
   P,h ⊢sc (Obj C (fs((F,D)v))) "
unfolding has_field_def
by(auto simp add: sc_fconf_def has_field_def dest: has_fields_fun)

lemma sc_oconf_fupd_arr [intro?]:
  " P,h ⊢sc v :≤ T; P,h ⊢sc (Arr T f el)  
   P,h ⊢sc (Arr T f (el[i := v])) "
by(auto dest: subsetD[OF set_update_subset_insert])

lemma sc_oconf_fupd_arr_fields:
  " P  Object has F:T (fm) in Object; P,h ⊢sc v :≤ T; P,h ⊢sc (Arr T' f el)  
   P,h ⊢sc (Arr T' (f((F, Object)  v)) el) "
by(auto dest: has_fields_fun simp add: sc_fconf_def has_field_def)

lemma sc_oconf_new: " P,h ⊢sc obj ; h a = None   P,h(a  arrobj) ⊢sc obj "
by(erule sc_oconf_hext)(rule sc_hext_new)

lemmas sc_oconf_upd_obj = sc_oconf_hext [OF _ sc_hext_upd_obj]

lemma sc_oconf_upd_arr:
  assumes "P,h ⊢sc obj "
  and ha: "h a = Arr T f el"
  shows "P,h(a  Arr T f' el') ⊢sc obj "
using assms
by(cases obj)(auto simp add: sc_conf_upd_arr[where h=h, OF ha] sc_fconf_def)

lemma sc_hconfD: " P ⊢sc h ; h a = Some obj   P,h ⊢sc obj "
unfolding sc_hconf_def by blast

lemmas sc_preallocated_new = sc.preallocated_hext[OF _ sc_hext_new]
lemmas sc_preallocated_upd_obj = sc.preallocated_hext [OF _ sc_hext_upd_obj]
lemmas sc_preallocated_upd_arr = sc.preallocated_hext [OF _ sc_hext_upd_arr]

lemma sc_hconf_new: " P ⊢sc h ; h a = None; P,h ⊢sc obj    P ⊢sc h(aobj) "
unfolding sc_hconf_def
by(auto intro: sc_oconf_new)

lemma sc_hconf_upd_obj: " P ⊢sc h ; h a = Some (Obj C fs); P,h ⊢sc (Obj C fs')    P ⊢sc h(a(Obj C fs')) "
unfolding sc_hconf_def
by(auto intro: sc_oconf_upd_obj simp del: sc_oconf.simps)

lemma sc_hconf_upd_arr: " P ⊢sc h ; h a = Some(Arr T f el); P,h ⊢sc (Arr T f' el')    P ⊢sc h(a(Arr T f' el')) "
unfolding sc_hconf_def
by(auto intro: sc_oconf_upd_arr simp del: sc_oconf.simps)

lemma sc_heap_conf: 
  "heap_conf addr2thread_id thread_id2addr sc_empty (sc_allocate P) sc_typeof_addr sc_heap_write (sc_hconf P) P"
proof
  show "P ⊢sc sc_empty " by(simp add: sc_hconf_def)
next
  fix h a hT
  assume "sc_typeof_addr h a = hT" "P ⊢sc h "
  thus "is_htype P hT"
    by(auto simp add: sc_typeof_addr_def sc_oconf_def dest!: sc_hconfD split: heapobj.split_asm)
next
  fix h h' hT a
  assume "P ⊢sc h " "(h', a)  sc_allocate P h hT" "is_htype P hT"
  thus "P ⊢sc h' "
    by(auto simp add: sc_allocate_def dest!: new_Addr_SomeD intro: sc_hconf_new sc_oconf_init split: if_split_asm)
next
  fix h a al T v h'
  assume "P ⊢sc h "
    and "sc.addr_loc_type P h a al T"
    and "P,h ⊢sc v :≤ T"
    and "sc_heap_write h a al v h'"
  thus "P ⊢sc h' "
    by(cases al)(fastforce elim!: sc.addr_loc_type.cases simp add: sc_typeof_addr_def intro: sc_hconf_upd_obj sc_oconf_fupd sc_hconfD sc_hconf_upd_arr sc_oconf_fupd_arr sc_oconf_fupd_arr_fields)+
qed

interpretation sc: heap_conf
  "addr2thread_id"
  "thread_id2addr"
  "sc_spurious_wakeups"
  "sc_empty"
  "sc_allocate P"
  "sc_typeof_addr"
  "sc_heap_read"
  "sc_heap_write"
  "sc_hconf P"
  "P"
for P 
by(rule sc_heap_conf)

lemma sc_heap_progress:
  "heap_progress addr2thread_id thread_id2addr sc_empty (sc_allocate P) sc_typeof_addr sc_heap_read sc_heap_write (sc_hconf P) P"
proof
  fix h a al T
  assume hconf: "P ⊢sc h "
    and alt: "sc.addr_loc_type P h a al T"
  from alt obtain arrobj where arrobj: "h a = arrobj"
    by(auto elim!: sc.addr_loc_type.cases simp add: sc_typeof_addr_def)
  from alt show "v. sc_heap_read h a al v  P,h ⊢sc v :≤ T"
  proof(cases)
    case (addr_loc_type_field U F fm D) 
    note [simp] = al = CField D F
    show ?thesis
    proof(cases "arrobj")
      case (Obj C' fs)
      with ‹sc_typeof_addr h a = U arrobj
      have [simp]: "C' = class_type_of U" by(auto simp add: sc_typeof_addr_def)
      from hconf arrobj Obj have "P,h ⊢sc Obj (class_type_of U) fs " by(auto dest: sc_hconfD)
      with P  class_type_of U has F:T (fm) in D obtain v 
        where "fs (F, D) = v" "P,h ⊢sc v :≤ T" by(fastforce simp add: sc_fconf_def)
      thus ?thesis using Obj arrobj by(auto intro: sc_heap_read.intros)
    next
      case (Arr T' f el)
      with ‹sc_typeof_addr h a = U arrobj
      have [simp]: "U = Array_type T' (length el)" by(auto simp add: sc_typeof_addr_def)
      from hconf arrobj Arr have "P,h ⊢sc Arr T' f el " by(auto dest: sc_hconfD)
      from P  class_type_of U has F:T (fm) in D have [simp]: "D = Object"
        by(auto dest: has_field_decl_above)
      with P,h ⊢sc Arr T' f el  P  class_type_of U has F:T (fm) in D
      obtain v where "f (F, Object) = v" "P,h ⊢sc v :≤ T"
        by(fastforce simp add: sc_fconf_def)
      thus ?thesis using Arr arrobj by(auto intro: sc_heap_read.intros)
    qed
  next
    case (addr_loc_type_cell n' n)
    with arrobj obtain f el
      where [simp]: "arrobj = Arr T f el"
      by(cases arrobj)(auto simp add: sc_typeof_addr_def)
    from addr_loc_type_cell arrobj
    have [simp]: "al = ACell n" "n < length el" by(auto simp add: sc_typeof_addr_def)
    from hconf arrobj have "P,h ⊢sc Arr T f el " by(auto dest: sc_hconfD)
    hence "P,h ⊢sc el ! n :≤ T" by(fastforce)
    thus ?thesis using arrobj by(fastforce intro: sc_heap_read.intros)
  qed
next
  fix h a al T v
  assume alt: "sc.addr_loc_type P h a al T"
  from alt obtain arrobj where arrobj: "h a = arrobj"
    by(auto elim!: sc.addr_loc_type.cases simp add: sc_typeof_addr_def)
  thus "h'. sc_heap_write h a al v h'" using alt
    by(cases arrobj)(fastforce intro: sc_heap_write.intros elim!: sc.addr_loc_type.cases simp add: sc_typeof_addr_def dest: has_field_decl_above)+
qed

interpretation sc: heap_progress
  "addr2thread_id"
  "thread_id2addr"
  "sc_spurious_wakeups"
  "sc_empty"
  "sc_allocate P"
  "sc_typeof_addr"
  "sc_heap_read"
  "sc_heap_write"
  "sc_hconf P"
  "P"
for P
by(rule sc_heap_progress)

lemma sc_heap_conf_read:
  "heap_conf_read addr2thread_id thread_id2addr sc_empty (sc_allocate P) sc_typeof_addr sc_heap_read sc_heap_write (sc_hconf P) P"
proof
  fix h a al v T
  assume read: "sc_heap_read h a al v"
    and alt: "sc.addr_loc_type P h a al T"
    and hconf: "P ⊢sc h "
  thus "P,h ⊢sc v :≤ T"
    by(auto elim!: sc_heap_read.cases sc.addr_loc_type.cases simp add: sc_typeof_addr_def)(fastforce dest!: sc_hconfD simp add: sc_fconf_def)+
qed

interpretation sc: heap_conf_read
  "addr2thread_id"
  "thread_id2addr"
  "sc_spurious_wakeups"
  "sc_empty"
  "sc_allocate P"
  "sc_typeof_addr"
  "sc_heap_read"
  "sc_heap_write"
  "sc_hconf P"
  "P"
for P
by(rule sc_heap_conf_read)

abbreviation sc_deterministic_heap_ops :: "'m prog  bool"
where "sc_deterministic_heap_ops  sc.deterministic_heap_ops TYPE('m)"

lemma sc_deterministic_heap_ops: "¬ sc_spurious_wakeups  sc_deterministic_heap_ops P"
by(rule sc.deterministic_heap_opsI)(auto elim: sc_heap_read.cases sc_heap_write.cases simp add: sc_allocate_def)

subsection ‹Code generation›

code_pred 
  (modes: i ⇒ i ⇒ i ⇒ i ⇒ bool, i ⇒ i ⇒ i ⇒ o ⇒ bool)
  sc_heap_read .

code_pred 
  (modes: i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ bool, i ⇒ i ⇒ i ⇒ i ⇒ o ⇒ bool)
  sc_heap_write .

lemma eval_sc_heap_read_i_i_i_o:
  "Predicate.eval (sc_heap_read_i_i_i_o h ad al) = sc_heap_read h ad al"
by(auto elim: sc_heap_read_i_i_i_oE intro: sc_heap_read_i_i_i_oI intro!: ext)

lemma eval_sc_heap_write_i_i_i_i_o:
  "Predicate.eval (sc_heap_write_i_i_i_i_o h ad al v) = sc_heap_write h ad al v"
by(auto elim: sc_heap_write_i_i_i_i_oE intro: sc_heap_write_i_i_i_i_oI intro!: ext)

end

Theory SC_Interp

(*  Title:      JinjaThreads/MM/SC_Interp.thy
    Author:     Andreas Lochbihler

    Interpret the language specific heap locales with the SC memory model
*)

theory SC_Interp
imports
  SC
  "../Compiler/Correctness" 
  "../J/Deadlocked"
  "../BV/JVMDeadlocked"
begin

text ‹
  Do not interpret these locales, it just takes too long to generate all definitions and theorems.
›

lemma sc_J_typesafe:
  "J_typesafe addr2thread_id thread_id2addr sc_empty (sc_allocate P) sc_typeof_addr sc_heap_read sc_heap_write (sc_hconf P) P"
by unfold_locales

lemma sc_JVM_typesafe:
  "JVM_typesafe addr2thread_id thread_id2addr sc_empty (sc_allocate P) sc_typeof_addr sc_heap_read sc_heap_write (sc_hconf P) P"
by unfold_locales

lemma compP2_compP1_convs:
  "is_type (compP2 (compP1 P)) = is_type P"
  "is_class (compP2 (compP1 P)) = is_class P"
  "sc.addr_loc_type (compP2 (compP1 P)) = sc.addr_loc_type P"
  "sc.conf (compP2 (compP1 P)) = sc.conf P"
by(simp_all add: compP2_def heap_base.compP_conf heap_base.compP_addr_loc_type fun_eq_iff split: addr_loc.splits)

lemma sc_J_JVM_conf_read:
  "J_JVM_conf_read addr2thread_id thread_id2addr sc_empty (sc_allocate P) sc_typeof_addr sc_heap_read sc_heap_write (sc_hconf P) P"
apply(rule J_JVM_conf_read.intro)
apply(rule J1_JVM_conf_read.intro)
apply(rule JVM_conf_read.intro)
 prefer 2
 apply(rule JVM_heap_conf.intro)
 apply(rule JVM_heap_conf_base'.intro)
 apply(unfold compP2_def compP1_def compP_heap compP_heap_conf compP_heap_conf_read)
 apply unfold_locales
done

end

Theory SC_Collections

(*  Title:      JinjaThreads/MM/SC_Collections.thy
    Author:     Andreas Lochbihler
*)

section ‹Sequential consistency with efficient data structures›

theory SC_Collections
imports
  "../Common/Conform"
  (*"../../Collections/impl/RBTMapImpl"
  "../../Collections/impl/TrieMapImpl"
  "../../Collections/impl/ListMapImpl"*)
  "../Basic/JT_ICF"
  MM
begin

hide_const (open) new_Addr
hide_fact (open) new_Addr_SomeD new_Addr_SomeI

subsection‹Objects and Arrays›

type_synonym fields = "(char, (cname, addr val) lm) tm"
type_synonym array_cells = "(nat, addr val) rbt"
type_synonym array_fields = "(vname, addr val) lm"

datatype heapobj
  = Obj cname fields                    ― ‹class instance with class name and fields›
  | Arr ty nat array_fields array_cells                 ― ‹element type, size, fields and cell contents›

lemma rec_heapobj [simp]: "rec_heapobj = case_heapobj"
by(auto intro!: ext split: heapobj.split)

primrec obj_ty  :: "heapobj  htype"
where
  "obj_ty (Obj c f)   = Class_type c"
| "obj_ty (Arr t si f e) = Array_type t si"

fun is_Arr :: "heapobj  bool" where
  "is_Arr (Obj C fs)      = False"
| "is_Arr (Arr T f si el) = True"

lemma is_Arr_conv:
  "is_Arr arrobj = (T si f el. arrobj = Arr T si f el)"
by(cases arrobj, auto)

lemma is_ArrE:
  " is_Arr arrobj; T si f el. arrobj = Arr T si f el  thesis   thesis"
  " ¬ is_Arr arrobj; C fs. arrobj = Obj C fs  thesis   thesis"
by(cases arrobj, auto)+

definition init_fields :: "((vname × cname) × ty) list  fields"
where
  "init_fields FDTs 
  foldr (λ((F, D), T) fields. 
           let F' = String.explode F
           in tm_update F' (lm_update D (default_val T)
                                      (case tm_lookup F' fields of None  lm_empty () | Some lm  lm)) fields)
        FDTs (tm_empty ())"

definition init_fields_array :: "(vname × ty) list  array_fields"
where
  "init_fields_array  lm.to_map  map (λ(F, T). (F, default_val T))"

definition init_cells :: "ty  nat  array_cells"
where "init_cells T n = foldl (λcells i. rm_update i (default_val T) cells) (rm_empty ()) [0..<n]"

primrec ― ‹a new, blank object with default values in all fields:›
  blank :: "'m prog  htype  heapobj"
where
  "blank P (Class_type C) = Obj C (init_fields (map (λ(FD, (T, fm)). (FD, T)) (TypeRel.fields P C)))"
| "blank P (Array_type T n) =
   Arr T n (init_fields_array (map (λ((F, D), (T, fm)). (F, T)) (TypeRel.fields P Object))) (init_cells T n)"

lemma obj_ty_blank [iff]: "obj_ty (blank P hT) = hT"
by(cases hT) simp_all

subsection‹Heap›

type_synonym heap = "(addr, heapobj) rbt"

translations
  (type) "heap" <= (type) "(nat, heapobj) rbt"

abbreviation sc_empty :: heap
where "sc_empty  rm_empty ()"

fun the_obj :: "heapobj  cname × fields" where
  "the_obj (Obj C fs) = (C, fs)"

fun the_arr :: "heapobj  ty × nat × array_fields × array_cells" where
  "the_arr (Arr T si f el) = (T, si, f, el)"

abbreviation
  cname_of :: "heap  addr  cname" where
  "cname_of hp a == fst (the_obj (the (rm_lookup a hp)))"

definition new_Addr :: "heap  addr option"
where "new_Addr h = Some (case rm_max h (λ_. True) of None  0 | Some (a, _)  a + 1)"

definition sc_allocate :: "'m prog  heap  htype  (heap × addr) set"
where
  "sc_allocate P h hT = 
   (case new_Addr h of None  {}
                   | Some a  {(rm_update a (blank P hT) h, a)})"

definition sc_typeof_addr :: "heap  addr  htype option"
where "sc_typeof_addr h a = map_option obj_ty (rm_lookup a h)"

inductive sc_heap_read :: "heap  addr  addr_loc  addr val  bool"
for h :: heap and a :: addr
where
  Obj: " rm_lookup a h = Obj C fs; tm_lookup (String.explode F) fs = fs'; lm_lookup D fs' = v   sc_heap_read h a (CField D F) v"
| Arr: " rm_lookup a h = Arr T si f el; n < si   sc_heap_read h a (ACell n) (the (rm_lookup n el))"
| ArrObj: " rm_lookup a h = Arr T si f el; lm_lookup F f = v   sc_heap_read h a (CField Object F) v"

hide_fact (open) Obj Arr ArrObj

inductive_cases sc_heap_read_cases [elim!]:
  "sc_heap_read h a (CField C F) v"
  "sc_heap_read h a (ACell n) v"

inductive sc_heap_write :: "heap  addr  addr_loc  addr val  heap  bool"
for h :: heap and a :: addr
where
  Obj:
  " rm_lookup a h = Obj C fs; F' = String.explode F;
     h' = rm_update a (Obj C (tm_update F' (lm_update D v (case tm_lookup (String.explode F) fs of None  lm_empty () | Some fs'  fs')) fs)) h 
   sc_heap_write h a (CField D F) v h'"

| Arr:
  " rm_lookup a h = Arr T si f el; h' = rm_update a (Arr T si f (rm_update n v el)) h 
   sc_heap_write h a (ACell n) v h'"

| ArrObj:
  " rm_lookup a h = Arr T si f el; h' = rm_update a (Arr T si (lm_update F v f) el) h 
   sc_heap_write h a (CField Object F) v h'"

hide_fact (open) Obj Arr ArrObj

inductive_cases sc_heap_write_cases [elim!]:
  "sc_heap_write h a (CField C F) v h'"
  "sc_heap_write h a (ACell n) v h'"

consts sc_spurious_wakeups :: bool

lemma new_Addr_SomeD: "new_Addr h = a  rm_lookup a h = None"
apply(simp add: new_Addr_def)
apply(drule rm.max_None[OF rm.invar])
apply(simp add: rm.lookup_correct rel_of_def)
apply(clarsimp simp add: rm.lookup_correct)
apply(frule rm.max_Some[OF rm.invar])
apply(clarsimp simp add: rel_of_def)
apply(hypsubst_thin)
apply(rule ccontr)
apply(clarsimp)
apply(drule_tac k'="Suc a" in rm.max_Some(2)[OF rm.invar])
apply(auto simp add: rel_of_def)
done

interpretation sc: 
  heap_base
    "addr2thread_id"
    "thread_id2addr"
    "sc_spurious_wakeups"
    "sc_empty"
    "sc_allocate P"
    "sc_typeof_addr"
    "sc_heap_read"
    "sc_heap_write"
  for P . 

text ‹Translate notation from heap_base›

abbreviation sc_preallocated :: "'m prog  heap  bool"
where "sc_preallocated == sc.preallocated TYPE('m)"

abbreviation sc_start_tid :: "'md prog  thread_id"
where "sc_start_tid  sc.start_tid TYPE('md)"

abbreviation sc_start_heap_ok :: "'m prog  bool"
where "sc_start_heap_ok  sc.start_heap_ok TYPE('m)"

abbreviation sc_start_heap :: "'m prog  heap"
where "sc_start_heap  sc.start_heap TYPE('m)"

abbreviation sc_start_state :: 
  "(cname  mname  ty list  ty  'm  addr val list  'x)
   'm prog  cname  mname  addr val list  (addr, thread_id, 'x, heap, addr) state"
where
  "sc_start_state f P  sc.start_state TYPE('m) P f P"

abbreviation sc_wf_start_state :: "'m prog  cname  mname  addr val list  bool"
where "sc_wf_start_state P  sc.wf_start_state TYPE('m) P P"

notation sc.conf ("_,_ ⊢sc _ :≤ _"  [51,51,51,51] 50)
notation sc.confs ("_,_ ⊢sc _ [:≤] _" [51,51,51,51] 50)
notation sc.hext ("_ ⊴sc _" [51,51] 50)

lemma new_Addr_SomeI: "a. new_Addr h = Some a"
by(simp add: new_Addr_def)

lemma sc_start_heap_ok: "sc_start_heap_ok P"
by(simp add: sc.start_heap_ok_def sc.start_heap_data_def initialization_list_def sc.create_initial_object_simps sc_allocate_def case_option_conv_if new_Addr_SomeI sys_xcpts_list_def del: blank.simps split del: option.split if_split)

lemma sc_wf_start_state_iff:
  "sc_wf_start_state P C M vs  (Ts T meth D. P  C sees M:TsT = meth in D  P,sc_start_heap P ⊢sc vs [:≤] Ts)"
by(simp add: sc.wf_start_state.simps sc_start_heap_ok)

lemma sc_heap:
  "heap addr2thread_id thread_id2addr (sc_allocate P) sc_typeof_addr sc_heap_write P"
proof
  fix h' a h hT
  assume "(h', a)  sc_allocate P h hT"
  thus "sc_typeof_addr h' a = hT"
    by(auto simp add: sc_allocate_def sc_typeof_addr_def rm.lookup_correct rm.update_correct dest: new_Addr_SomeD split: if_split_asm)
next
  fix h h' hT a
  assume "(h', a)  sc_allocate P h hT"
  from this[symmetric] show "h ⊴sc h'"
    by(fastforce simp add: sc_allocate_def sc_typeof_addr_def sc.hext_def rm.lookup_correct rm.update_correct intro!: map_leI dest: new_Addr_SomeD)
next
  fix h a al v h'
  assume "sc_heap_write h a al v h'"
  thus "h ⊴sc h'"
    by(cases al)(auto intro!: sc.hextI simp add: sc_typeof_addr_def rm.lookup_correct rm.update_correct)
qed simp

interpretation sc: 
  heap 
    "addr2thread_id"
    "thread_id2addr"
    "sc_spurious_wakeups"
    "sc_empty"
    "sc_allocate P"
    "sc_typeof_addr"
    "sc_heap_read"
    "sc_heap_write"
    P
  for P by(rule sc_heap)

declare sc.typeof_addr_thread_id2_addr_addr2thread_id [simp del]

lemma sc_hext_new:
  "rm_lookup a h = None  h ⊴sc rm_update a arrobj h"
by(rule sc.hextI)(auto simp add: sc_typeof_addr_def rm.lookup_correct rm.update_correct dest!: new_Addr_SomeD)

lemma sc_hext_upd_obj: "rm_lookup a h = Some (Obj C fs)  h ⊴sc rm_update a (Obj C fs') h"
by(rule sc.hextI)(auto simp:fun_upd_apply sc_typeof_addr_def rm.lookup_correct rm.update_correct)

lemma sc_hext_upd_arr: " rm_lookup a h = Some (Arr T si f e)   h ⊴sc rm_update a (Arr T si f' e') h"
by(rule sc.hextI)(auto simp:fun_upd_apply sc_typeof_addr_def rm.lookup_correct rm.update_correct)

subsection ‹Conformance›

definition sc_oconf :: "'m prog  heap  heapobj  bool"   ("_,_ ⊢sc _ " [51,51,51] 50)
where
  "P,h ⊢sc obj   
   (case obj of 
     Obj C fs  
        is_class P C  
        (F D T fm. P  C has F:T (fm) in D  
           (fs' v. tm_α fs (String.explode F) = Some fs'  lm_α fs' D = Some v  P,h ⊢sc v :≤ T))
   | Arr T si f el  
      is_type P (T⌊⌉)  (n. n < si  (v. rm_α el n = Some v  P,h ⊢sc v :≤ T)) 
      (F T fm. P  Object has F:T (fm) in Object  (v. lm_lookup F f = Some v  P,h ⊢sc v :≤ T)))"

definition sc_hconf :: "'m prog  heap  bool"  ("_ ⊢sc _ " [51,51] 50)
where "P ⊢sc h   (a obj. rm_α h a = Some obj  P,h ⊢sc obj )"

interpretation sc: 
  heap_conf_base  
    "addr2thread_id"
    "thread_id2addr"
    "sc_spurious_wakeups"
    "sc_empty"
    "sc_allocate P"
    "sc_typeof_addr"
    "sc_heap_read"
    "sc_heap_write"
    "sc_hconf P"
    "P"
  for P 
.

lemma sc_conf_upd_obj: "rm_lookup a h = Some(Obj C fs)  (P,rm_update a (Obj C fs') h ⊢sc x :≤ T) = (P,h ⊢sc x :≤ T)"
apply (unfold sc.conf_def)
apply (rule val.induct)
apply (auto simp:fun_upd_apply)
apply (auto simp add: sc_typeof_addr_def rm.lookup_correct rm.update_correct split: if_split_asm)
done

lemma sc_conf_upd_arr:
  "rm_lookup a h = Some(Arr T si f el)  (P,rm_update a (Arr T si f' el') h ⊢sc x :≤ T') = (P,h ⊢sc x :≤ T')"
apply(unfold sc.conf_def)
apply (rule val.induct)
apply (auto simp:fun_upd_apply)
apply(auto simp add: sc_typeof_addr_def rm.lookup_correct rm.update_correct split: if_split_asm)
done

lemma sc_oconf_hext: "P,h ⊢sc obj   h ⊴sc h'  P,h' ⊢sc obj "
unfolding sc_oconf_def
by(fastforce split: heapobj.split elim: sc.conf_hext)

lemma map_of_fields_init_fields:
  assumes "map_of FDTs (F, D) = (T, fm)"
  shows "fs' v. tm_α (init_fields (map (λ(FD, (T, fm)). (FD, T)) FDTs)) (String.explode F) = fs'  lm_α fs' D = v  sc.conf P h v T"
using assms
  by(induct FDTs)(auto simp add: tm.lookup_correct tm.update_correct lm.update_correct init_fields_def String.explode_inject)

lemma sc_oconf_init_fields:
  assumes "P  C has_fields FDTs"
  shows "P,h ⊢sc (Obj C (init_fields (map (λ(FD, (T, fm)). (FD, T)) FDTs))) "
using assms has_fields_is_class[OF assms] map_of_fields_init_fields[of FDTs]
by(fastforce simp add: has_field_def sc_oconf_def dest: has_fields_fun)

lemma sc_oconf_init_arr:
  assumes type: "is_type P (T⌊⌉)"
  shows "P,h ⊢sc Arr T n (init_fields_array (map (λ((F, D), (T, fm)). (F, T)) (TypeRel.fields P Object))) (init_cells T n) "
proof -
  { fix n'
    assume "n' < n"
    { fix rm and k :: nat
      assume "i<k. v. rm_α rm i = v  sc.conf P h v T"
      with n' < n have "v. rm_α (foldl (λcells i. rm_update i (default_val T) cells) rm [k..<n]) n' = v  sc.conf P h v T"
        by(induct m"n-k" arbitrary: n k rm)(auto simp add: rm.update_correct upt_conv_Cons type)
    }
    from this[of 0 "rm_empty ()"]
    have "v. rm_α (foldl (λcells i. rm_update i (default_val T) cells) (rm_empty ()) [0..<n]) n' = v  sc.conf P h v T" by simp
  }
  moreover
  { fix F T fm
    assume "P  Object has F:T (fm) in Object"
    then obtain FDTs where has: "P  Object has_fields FDTs"
      and FDTs: "map_of FDTs (F, Object) = (T, fm)"
      by(auto simp add: has_field_def)
    from has have "snd ` fst ` set FDTs  {Object}" by(rule Object_has_fields_Object)
    with FDTs have "map_of (map ((λ(F, T). (F, default_val T))  (λ((F, D), T, fm). (F, T))) FDTs) F = default_val T"
      by(induct FDTs) auto
    with has FDTs
    have "v. lm_lookup F (init_fields_array (map (λ((F, D), T, fm). (F, T)) (TypeRel.fields P Object))) = v 
              sc.conf P h v T"
      by(auto simp add: init_fields_array_def lm_correct has_field_def)
  }
  ultimately show ?thesis using type by(auto simp add: sc_oconf_def init_cells_def)
qed

lemma sc_oconf_fupd [intro?]:
  " P  C has F:T (fm) in D; P,h ⊢sc v :≤ T; P,h ⊢sc (Obj C fs) ;
    fs' = (case tm_lookup (String.explode F) fs of None  lm_empty () | Some fs'  fs') 
   P,h ⊢sc (Obj C (tm_update (String.explode F) (lm_update D v fs') fs)) "
unfolding sc_oconf_def has_field_def
apply(auto dest: has_fields_fun simp add: lm.update_correct tm.update_correct tm.lookup_correct String.explode_inject)
apply(drule (1) has_fields_fun, fastforce)
apply(drule (1) has_fields_fun, fastforce)
done

lemma sc_oconf_fupd_arr [intro?]:
  " P,h ⊢sc v :≤ T; P,h ⊢sc (Arr T si f el)  
   P,h ⊢sc (Arr T si f (rm_update i v el)) "
unfolding sc_oconf_def
by(auto simp add: rm.update_correct)

lemma sc_oconf_fupd_arr_fields:
  " P  Object has F:T (fm) in Object; P,h ⊢sc v :≤ T; P,h ⊢sc (Arr T' si f el)  
   P,h ⊢sc (Arr T' si (lm_update F v f) el) "
unfolding sc_oconf_def by(auto dest: has_field_fun simp add: lm_correct)

lemma sc_oconf_new: " P,h ⊢sc obj ; rm_lookup a h = None   P,rm_update a arrobj h ⊢sc obj "
by(erule sc_oconf_hext)(rule sc_hext_new)

lemmas sc_oconf_upd_obj = sc_oconf_hext [OF _ sc_hext_upd_obj]

lemma sc_oconf_upd_arr:
  assumes "P,h ⊢sc obj "
  and ha: "rm_lookup a h = Arr T si f el"
  shows "P,rm_update a (Arr T si f' el') h ⊢sc obj "
using assms
by(fastforce simp add: sc_oconf_def sc_conf_upd_arr[OF ha] split: heapobj.split)

lemma sc_oconf_blank: "is_htype P hT  P,h ⊢sc blank P hT "
apply(cases hT)
 apply(fastforce dest: map_of_fields_init_fields simp add: has_field_def sc_oconf_def)
by(auto intro: sc_oconf_init_arr)

lemma sc_hconfD: " P ⊢sc h ; rm_lookup a h = Some obj   P,h ⊢sc obj "
unfolding sc_hconf_def by(auto simp add: rm.lookup_correct)

lemmas sc_preallocated_new = sc.preallocated_hext[OF _ sc_hext_new]
lemmas sc_preallocated_upd_obj = sc.preallocated_hext [OF _ sc_hext_upd_obj]
lemmas sc_preallocated_upd_arr = sc.preallocated_hext [OF _ sc_hext_upd_arr]

lemma sc_hconf_new: " P ⊢sc h ; rm_lookup a h = None; P,h ⊢sc obj    P ⊢sc rm_update a obj h "
unfolding sc_hconf_def
by(auto intro: sc_oconf_new simp add: rm.lookup_correct rm.update_correct)

lemma sc_hconf_upd_obj: " P ⊢sc h ; rm_lookup a h = Some (Obj C fs); P,h ⊢sc (Obj C fs')    P ⊢sc rm_update a (Obj C fs') h "
unfolding sc_hconf_def
by(auto intro: sc_oconf_upd_obj simp add: rm.lookup_correct rm.update_correct)

lemma sc_hconf_upd_arr: " P ⊢sc h ; rm_lookup a h = Some(Arr T si f el); P,h ⊢sc (Arr T si f' el')    P ⊢sc rm_update a (Arr T si f' el') h "
unfolding sc_hconf_def
by(auto intro: sc_oconf_upd_arr simp add: rm.lookup_correct rm.update_correct)

lemma sc_heap_conf: 
  "heap_conf addr2thread_id thread_id2addr sc_empty (sc_allocate P) sc_typeof_addr sc_heap_write (sc_hconf P) P"
proof
  show "P ⊢sc sc_empty " by(simp add: sc_hconf_def rm.empty_correct)
next
  fix h a hT
  assume "sc_typeof_addr h a = hT" "P ⊢sc h "
  thus "is_htype P hT"
    by(auto simp add: sc_typeof_addr_def sc_oconf_def dest!: sc_hconfD split: heapobj.split_asm)
next
  fix h' hT h a
  assume "P ⊢sc h " "(h', a)  sc_allocate P h hT" "is_htype P hT"
  thus "P ⊢sc h' "
    by(auto simp add: sc_allocate_def dest!: new_Addr_SomeD intro: sc_hconf_new sc_oconf_blank split: if_split_asm)
next
  fix h a al T v h'
  assume "P ⊢sc h "
    and "sc.addr_loc_type P h a al T"
    and "P,h ⊢sc v :≤ T"
    and "sc_heap_write h a al v h'"
  thus "P ⊢sc h' "
    by(cases al)(fastforce elim!: sc.addr_loc_type.cases simp add: sc_typeof_addr_def intro: sc_hconf_upd_obj sc_oconf_fupd sc_hconfD sc_hconf_upd_arr sc_oconf_fupd_arr sc_oconf_fupd_arr_fields)+
qed

interpretation sc: 
  heap_conf
    "addr2thread_id"
    "thread_id2addr"
    "sc_spurious_wakeups"
    "sc_empty"
    "sc_allocate P"
    "sc_typeof_addr"
    "sc_heap_read"
    "sc_heap_write"
    "sc_hconf P"
    "P"
  for P 
by(rule sc_heap_conf)

lemma sc_heap_progress:
  "heap_progress addr2thread_id thread_id2addr sc_empty (sc_allocate P) sc_typeof_addr sc_heap_read sc_heap_write (sc_hconf P) P"
proof
  fix h a al T
  assume hconf: "P ⊢sc h "
    and alt: "sc.addr_loc_type P h a al T"
  from alt obtain arrobj where arrobj: "rm_lookup a h = arrobj"
    by(auto elim!: sc.addr_loc_type.cases simp add: sc_typeof_addr_def)
  from alt show "v. sc_heap_read h a al v  P,h ⊢sc v :≤ T"
  proof(cases)
    case (addr_loc_type_field U F fm D) 
    note [simp] = al = CField D F
    show ?thesis
    proof(cases "arrobj")
      case (Obj C' fs)
      with ‹sc_typeof_addr h a = U arrobj
      have [simp]: "C' = class_type_of U" by(auto simp add: sc_typeof_addr_def)
      from hconf arrobj Obj have "P,h ⊢sc Obj (class_type_of U) fs " by(auto dest: sc_hconfD)
      with P  class_type_of U has F:T (fm) in D obtain fs' v 
      where "tm_lookup (String.explode F) fs = fs'" "lm_lookup D fs' = v" "P,h ⊢sc v :≤ T"
      by(fastforce simp add: sc_oconf_def tm.lookup_correct lm.lookup_correct)
      thus ?thesis using Obj arrobj by(auto intro: sc_heap_read.intros)
    next
      case (Arr T' si f el)
      with ‹sc_typeof_addr h a = U arrobj
      have [simp]: "U = Array_type T' si" by(auto simp add: sc_typeof_addr_def)
      from hconf arrobj Arr have "P,h ⊢sc Arr T' si f el " by(auto dest: sc_hconfD)
      from P  class_type_of U has F:T (fm) in D have [simp]: "D = Object"
        by(auto dest: has_field_decl_above)
      with P,h ⊢sc Arr T' si f el  P  class_type_of U has F:T (fm) in D
      obtain v where "lm_lookup F f = v" "P,h ⊢sc v :≤ T"
        by(fastforce simp add: sc_oconf_def)
      thus ?thesis using Arr arrobj by(auto intro: sc_heap_read.intros)
    qed
  next
    case (addr_loc_type_cell n' n)
    with arrobj obtain si f el
      where [simp]: "arrobj = Arr T si f el"
      by(cases arrobj)(auto simp add: sc_typeof_addr_def)
    from addr_loc_type_cell arrobj
    have [simp]: "al = ACell n" and n: "n < si" by(auto simp add: sc_typeof_addr_def)
    from hconf arrobj have "P,h ⊢sc Arr T si f el " by(auto dest: sc_hconfD)
    with n obtain v where "rm_lookup n el = v" "P,h ⊢sc v :≤ T"
      by(fastforce simp add: sc_oconf_def rm.lookup_correct)
    thus ?thesis using arrobj n by(fastforce intro: sc_heap_read.intros)
  qed
next
  fix h a al T v
  assume alt: "sc.addr_loc_type P h a al T"
  from alt obtain arrobj where arrobj: "rm_lookup a h = arrobj"
    by(auto elim!: sc.addr_loc_type.cases simp add: sc_typeof_addr_def)
  thus "h'. sc_heap_write h a al v h'" using alt
    by(cases arrobj)(fastforce intro: sc_heap_write.intros elim!: sc.addr_loc_type.cases simp add: sc_typeof_addr_def dest: has_field_decl_above)+
qed

interpretation sc: 
  heap_progress
    "addr2thread_id"
    "thread_id2addr"
    "sc_spurious_wakeups"
    "sc_empty"
    "sc_allocate P"
    "sc_typeof_addr"
    "sc_heap_read"
    "sc_heap_write"
    "sc_hconf P"
    "P"
  for P
by(rule sc_heap_progress)

lemma sc_heap_conf_read:
  "heap_conf_read addr2thread_id thread_id2addr sc_empty (sc_allocate P) sc_typeof_addr sc_heap_read sc_heap_write (sc_hconf P) P"
proof
  fix h a al v T
  assume read: "sc_heap_read h a al v"
    and alt: "sc.addr_loc_type P h a al T"
    and hconf: "P ⊢sc h "
  thus "P,h ⊢sc v :≤ T"
    apply(auto elim!: sc_heap_read.cases sc.addr_loc_type.cases simp add: sc_typeof_addr_def)
    apply(fastforce dest!: sc_hconfD simp add: sc_oconf_def tm.lookup_correct lm.lookup_correct rm.lookup_correct)+
    done
qed

interpretation sc: 
  heap_conf_read
    "addr2thread_id"
    "thread_id2addr"
    "sc_spurious_wakeups"
    "sc_empty"
    "sc_allocate P"
    "sc_typeof_addr"
    "sc_heap_read"
    "sc_heap_write"
    "sc_hconf P"
    "P"
  for P
by(rule sc_heap_conf_read)

abbreviation sc_deterministic_heap_ops :: "'m prog  bool"
where "sc_deterministic_heap_ops  sc.deterministic_heap_ops TYPE('m)"

lemma sc_deterministic_heap_ops: "¬ sc_spurious_wakeups  sc_deterministic_heap_ops P"
by(rule sc.deterministic_heap_opsI)(auto elim: sc_heap_read.cases sc_heap_write.cases simp add: sc_allocate_def)

subsection ‹Code generation›

code_pred 
  (modes: i  i  i  i  bool, i  i  i  o  bool)
  sc_heap_read .

code_pred 
  (modes: i  i  i  i  i  bool, i  i  i  i  o  bool)
  sc_heap_write .

lemma eval_sc_heap_read_i_i_i_o:
  "Predicate.eval (sc_heap_read_i_i_i_o h ad al) = sc_heap_read h ad al"
by(auto elim: sc_heap_read_i_i_i_oE intro: sc_heap_read_i_i_i_oI intro!: ext)

lemma eval_sc_heap_write_i_i_i_i_o:
  "Predicate.eval (sc_heap_write_i_i_i_i_o h ad al v) = sc_heap_write h ad al v"
by(auto elim: sc_heap_write_i_i_i_i_oE intro: sc_heap_write_i_i_i_i_oI intro!: ext)

end

Theory Orders

(*  Title:      JinjaThreads/MM/Orders.thy
    Author:     Andreas Lochbihler
*)

section ‹Orders as predicates›

theory Orders
imports
  Main
begin

subsection ‹Preliminaries›

text ‹transfer @{term "refl_on"} et al. from @{theory HOL.Relation} to predicates›

abbreviation refl_onP :: "'a set  ('a  'a  bool)  bool"
where "refl_onP A r  refl_on A {(x, y). r x y}"

abbreviation reflP :: "('a  'a  bool)  bool" 
where "reflP == refl_onP UNIV"

abbreviation symP :: "('a  'a  bool)  bool"
where "symP r  sym {(x, y). r x y}"

abbreviation total_onP :: "'a set  ('a  'a  bool)  bool"
where "total_onP A r  total_on A {(x, y). r x y}"

abbreviation irreflP :: "('a  'a  bool)  bool"
where "irreflP r == irrefl {(x, y). r x y}"

definition irreflclp :: "('a  'a  bool)  'a  'a  bool" ("_" [1000] 1000)
where "r a b = (r a b  a  b)"

definition porder_on :: "'a set  ('a  'a  bool)  bool"
where "porder_on A r  refl_onP A r  transp r  antisymp r"

definition torder_on :: "'a set  ('a  'a  bool)  bool"
where "torder_on A r  porder_on A r  total_onP A r"

definition order_consistent :: "('a  'a  bool)  ('a  'a  bool)  bool"
where "order_consistent r s  (a a'. r a a'  s a' a  a = a')"

definition restrictP :: "('a  'a  bool)  'a set  'a  'a  bool" (infixl "|`" 110)
where "(r |` A) a b  r a b  a  A  b  A"

definition inv_imageP :: "('a  'a  bool)  ('b  'a)  'b  'b  bool"
where [iff]: "inv_imageP r f a b  r (f a) (f b)"

lemma refl_onPI: "(a a'. r a a'  a  A  a'  A)  (a. a : A  r a a)  refl_onP A r"
by(rule refl_onI)(auto)

lemma refl_onPD: "refl_onP A r ==> a : A ==> r a a"
by(drule (1) refl_onD)(simp)

lemma refl_onPD1: "refl_onP A r ==> r a b ==> a : A"
by(erule refl_onD1)(simp)

lemma refl_onPD2: "refl_onP A r ==> r a b ==> b : A"
by(erule refl_onD2)(simp)

lemma refl_onP_Int: "refl_onP A r ==> refl_onP B s ==> refl_onP (A  B) (λa a'. r a a'  s a a')"
by(drule (1) refl_on_Int)(simp add: split_def inf_fun_def inf_set_def)

lemma refl_onP_Un: "refl_onP A r ==> refl_onP B s ==> refl_onP (A  B) (λa a'. r a a'  s a a')"
by(drule (1) refl_on_Un)(simp add: split_def sup_fun_def sup_set_def)

lemma refl_onP_empty[simp]: "refl_onP {} (λa a'. False)"
unfolding split_def by simp

lemma refl_onP_tranclp:
  assumes "refl_onP A r"
  shows "refl_onP A r^++"
proof(rule refl_onPI)
  fix a a'
  assume "r^++ a a'"
  thus "a  A  a'  A"
    by(induct)(blast intro: refl_onPD1[OF assms] refl_onPD2[OF assms])+
next
  fix a
  assume "a  A"
  from refl_onPD[OF assms this] show "r^++ a a" ..
qed

lemma irreflPI: "(a. ¬ r a a)  irreflP r"
unfolding irrefl_def by blast

lemma irreflPE:
  assumes "irreflP r" 
  obtains "a. ¬ r a a"
using assms unfolding irrefl_def by blast

lemma irreflPD: " irreflP r; r a a   False"
unfolding irrefl_def by blast

lemma irreflclpD:
  "r a b  r a b  a  b"
by(simp add: irreflclp_def)

lemma irreflclpI [intro!]:
  " r a b; a  b   r a b"
by(simp add: irreflclp_def)

lemma irreflclpE [elim!]:
  assumes "r a b"
  obtains "r a b" "a  b"
using assms by(simp add: irreflclp_def)

lemma transPI: "(x y z.  r x y; r y z   r x z)  transp r"
  by (fact transpI)

lemma transPD: "transp r; r x y; r y z   r x z"
  by (fact transpD)

lemma transP_tranclp: "transp r^++"
  by (fact trans_trancl [to_pred])

lemma antisymPI: "(x y.  r x y; r y x   x = y)  antisymp r"
  by (fact antisympI)

lemma antisymPD: " antisymp r; r a b; r b a   a = b"
  by (fact antisympD)

lemma antisym_subset:
  " antisymp r; a a'. s a a'  r a a'   antisymp s"
  by (blast intro: antisymp_less_eq [of s r])

lemma symPI: "(x y. r x y  r y x)  symP r"
by(rule symI)(blast)

lemma symPD: " symP r; r x y   r y x"
by(blast dest: symD)

subsection ‹Easy properties›

lemma porder_onI:
  " refl_onP A r; antisymp r; transp r   porder_on A r"
unfolding porder_on_def by blast

lemma porder_onE:
  assumes "porder_on A r"
  obtains "refl_onP A r" "antisymp r" "transp r"
using assms unfolding porder_on_def by blast

lemma torder_onI:
  " porder_on A r; total_onP A r   torder_on A r"
unfolding torder_on_def by blast

lemma torder_onE:
  assumes "torder_on A r"
  obtains "porder_on A r" "total_onP A r"
using assms unfolding torder_on_def by blast

lemma total_onI:
  "(x y.  x  A; y  A   (x, y)  r  x = y  (y, x)  r)  total_on A r"
unfolding total_on_def by blast

lemma total_onPI:
  "(x y.  x  A; y  A   r x y  x = y  r y x)  total_onP A r"
by(rule total_onI) simp

lemma total_onD:
  " total_on A r; x  A; y  A   (x, y)  r  x = y  (y, x)  r"
unfolding total_on_def by blast

lemma total_onPD:
  " total_onP A r; x  A; y  A   r x y  x = y  r y x"
by(drule (2) total_onD) blast

subsection ‹Order consistency›

lemma order_consistentI:
  "(a a'.  r a a'; s a' a   a = a')  order_consistent r s"
unfolding order_consistent_def by blast

lemma order_consistentD:
  " order_consistent r s; r a a'; s a' a   a = a'"
unfolding order_consistent_def by blast

lemma order_consistent_subset:
  " order_consistent r s; a a'. r' a a'  r a a'; a a'. s' a a'  s a a'   order_consistent r' s'"
by(blast intro: order_consistentI order_consistentD)

lemma order_consistent_sym:
  "order_consistent r s  order_consistent s r"
by(blast intro: order_consistentI dest: order_consistentD)

lemma antisym_order_consistent_self:
  "antisymp r  order_consistent r r"
by(rule order_consistentI)(erule antisympD, simp_all)

lemma total_on_refl_on_consistent_into:
  assumes r: "total_onP A r" "refl_onP A r"
  and consist: "order_consistent r s"
  and x: "x  A" and y: "y  A" and s: "s x y"
  shows "r x y"
proof(cases "x = y")
  case True
  with r x y show ?thesis by(blast intro: refl_onPD)
next
  case False
  with r x y have "r x y  r y x" by(blast dest: total_onD)
  thus ?thesis
  proof
    assume "r y x"
    with s consist have "x = y" by(blast dest: order_consistentD)
    with False show ?thesis by(contradiction)
  qed
qed

lemma porder_torder_tranclpE [consumes 5, case_names base step]:
  assumes r: "porder_on A r"
  and s: "torder_on B s"
  and consist: "order_consistent r s"
  and B_subset_A: "B  A"
  and trancl: "(λa b. r a b  s a b)^++ x y"
  obtains "r x y"
        | u v where "r x u" "s u v" "r v y"
proof(atomize_elim)
  from r have "refl_onP A r" "transp r" by(blast elim: porder_onE)+
  from s have "refl_onP B s" "total_onP B s" "transp s"
    by(blast elim: torder_onE porder_onE)+

  from trancl show "r x y  (u v. r x u  s u v  r v y)"
  proof(induct)
    case (base y)
    thus ?case
    proof
      assume "s x y"
      with s have "x  B" "y  B"
        by(blast elim: torder_onE porder_onE dest: refl_onPD1 refl_onPD2)+
      with B_subset_A have "x  A" "y  A" by blast+
      with refl_onPD[OF ‹refl_onP A r, of x] refl_onPD[OF ‹refl_onP A r, of y] s x y
      show ?thesis by(iprover)
    next
      assume "r x y"
      thus ?thesis ..
    qed
  next
    case (step y z)
    note IH = r x y  (u v. r x u  s u v  r v y)
    from r y z  s y z show ?case
    proof
      assume "s y z"
      with ‹refl_onP B s have "y  B" "z  B"
        by(blast dest: refl_onPD2 refl_onPD1)+
      from IH show ?thesis
      proof
        assume "r x y"
        moreover from z  B B_subset_A r have "r z z"
          by(blast elim: porder_onE dest: refl_onPD)
        ultimately show ?thesis using s y z by blast
      next
        assume "u v. r x u  s u v  r v y"
        then obtain u v where "r x u" "s u v" "r v y" by blast
        from ‹refl_onP B s s u v have "v  B" by(rule refl_onPD2)
        with ‹total_onP B s ‹refl_onP B s order_consistent_sym[OF consist]
        have "s v y" using y  B r v y
          by(rule total_on_refl_on_consistent_into)
        with ‹transp s have "s v z" using s y z by(rule transPD)
        with ‹transp s s u v have "s u z" by(rule transPD)
        moreover from z  B B_subset_A have "z  A" ..
        with ‹refl_onP A r have "r z z" by(rule refl_onPD)
        ultimately show ?thesis using r x u by blast
      qed
    next
      assume "r y z"
      with IH show ?thesis
        by(blast intro: transPD[OF ‹transp r])
    qed
  qed
qed

lemma torder_on_porder_on_consistent_tranclp_antisym:
  assumes r: "porder_on A r"
  and s: "torder_on B s"
  and consist: "order_consistent r s"
  and B_subset_A: "B  A"
  shows "antisymp (λx y. r x y  s x y)^++"
proof(rule antisymPI)
  fix x y
  let ?rs = "λx y. r x y  s x y"
  assume "?rs^++ x y" "?rs^++ y x"
  from r have "antisymp r" "transp r" by(blast elim: porder_onE)+
  from s have "total_onP B s" "refl_onP B s" "transp s" "antisymp s"
    by(blast elim: torder_onE porder_onE)+

  from r s consist B_subset_A ?rs^++ x y
  show "x = y"
  proof(cases rule: porder_torder_tranclpE)
    case base
    from r s consist B_subset_A ?rs^++ y x
    show ?thesis
    proof(cases rule: porder_torder_tranclpE)
      case base
      with ‹antisymp r r x y show ?thesis by(rule antisymPD)
    next
      case (step u v)
      from r v x r x y r y u have "r v u" by(blast intro: transPD[OF ‹transp r])
      with consist have "v = u" using s u v by(rule order_consistentD)
      with r y u r v x have "r y x" by(blast intro: transPD[OF ‹transp r])
      with r x y show ?thesis by(rule antisymPD[OF ‹antisymp r])
    qed
  next
    case (step u v)
    from r s consist B_subset_A ?rs^++ y x
    show ?thesis
    proof(cases rule: porder_torder_tranclpE)
      case base
      from r v y r y x r x u have "r v u" by(blast intro: transPD[OF ‹transp r])
      with order_consistent_sym[OF consist] s u v
      have "u = v" by(rule order_consistentD)
      with r v y r x u have "r x y" by(blast intro: transPD[OF ‹transp r])
      thus ?thesis using r y x by(rule antisymPD[OF ‹antisymp r])
    next
      case (step u' v')
      note r_into_s = total_on_refl_on_consistent_into[OF ‹total_onP B s ‹refl_onP B s order_consistent_sym[OF consist]]
      from ‹refl_onP B s s u v s u' v'
      have "u  B" "v  B" "u'  B" "v'  B" by(blast dest: refl_onPD1 refl_onPD2)+
      from r v' x r x u have "r v' u" by(rule transPD[OF ‹transp r])
      with v'  B u  B have "s v' u" by(rule r_into_s)
      also note s u v
      also (transPD[OF ‹transp s])
      from r v y r y u' have "r v u'" by(rule transPD[OF ‹transp r])
      with v  B u'  B have "s v u'" by(rule r_into_s)
      finally (transPD[OF ‹transp s])
      have "v' = u'" using s u' v' by(rule antisymPD[OF ‹antisymp s])
      moreover with s v u' s v' u have "s v u" by(blast intro: transPD[OF ‹transp s])
      with s u v have "u = v" by(rule antisymPD[OF ‹antisymp s])
      ultimately have "r x y" "r y x" using r x u r v y r y u' r v' x
        by(blast intro: transPD[OF ‹transp r])+
      thus ?thesis by(rule antisymPD[OF ‹antisymp r])
    qed
  qed
qed

lemma porder_on_torder_on_tranclp_porder_onI:
  assumes r: "porder_on A r"
  and s: "torder_on B s" 
  and consist: "order_consistent r s"
  and subset: "B  A"
  shows "porder_on A (λa b. r a b  s a b)^++"
proof(rule porder_onI)
  let ?rs = "λa b. r a b  s a b"
  from r have "refl_onP A r" by(rule porder_onE)
  moreover from s have "refl_onP B s" by(blast elim: torder_onE porder_onE)
  ultimately have "refl_onP (A  B) ?rs" by(rule refl_onP_Un)
  also from subset have "A  B = A" by blast
  finally show "refl_onP A ?rs^++" by(rule refl_onP_tranclp)

  show "transp ?rs^++" by(rule transP_tranclp)

  from r s consist subset show "antisymp ?rs^++"
    by (rule torder_on_porder_on_consistent_tranclp_antisym)
qed

lemma porder_on_sub_torder_on_tranclp_porder_onI:
  assumes r: "porder_on A r"
  and s: "torder_on B s"
  and consist: "order_consistent r s"
  and t: "x y. t x y  s x y"
  and subset: "B  A"
  shows "porder_on A (λx y. r x y  t x y)^++"
proof(rule porder_onI)
  let ?rt = "λx y. r x y  t x y"
  let ?rs = "λx y. r x y  s x y"
  from r s consist subset have "antisymp ?rs^++"
    by(rule torder_on_porder_on_consistent_tranclp_antisym)
  thus "antisymp ?rt^++"
  proof(rule antisym_subset)
    fix x y
    assume "?rt^++ x y" thus "?rs^++ x y"
      by(induct)(blast intro: tranclp.r_into_trancl t tranclp.trancl_into_trancl t)+
  qed

  from s have "refl_onP B s" by(blast elim: porder_onE torder_onE)
  { fix x y
    assume "t x y"
    hence "s x y" by(rule t)
    hence "x  B" "y  B"
      by(blast dest: refl_onPD1[OF ‹refl_onP B s] refl_onPD2[OF ‹refl_onP B s])+
    with subset have "x  A" "y  A" by blast+ }
  note t_reflD = this

  from r have "refl_onP A r" by(rule porder_onE)
  show "refl_onP A ?rt^++"
  proof(rule refl_onPI)
    fix a a'
    assume "?rt^++ a a'"
    thus "a  A  a'  A"
      by(induct)(auto dest: refl_onPD1[OF ‹refl_onP A r] refl_onPD2[OF ‹refl_onP A r] t_reflD)
  next
    fix a
    assume "a  A"
    with ‹refl_onP A r have "r a a" by(rule refl_onPD)
    thus "?rt^++ a a" by(blast intro: tranclp.r_into_trancl)
  qed

  show "transp ?rt^++" by(rule transP_tranclp)
qed

subsection ‹Order restrictions›

lemma restrictPI [intro!, simp]:
  " r a b; a  A; b  A   (r |` A) a b"
unfolding restrictP_def by simp

lemma restrictPE [elim!]:
  assumes "(r |` A) a b"
  obtains "r a b" "a  A" "b  A"
using assms unfolding restrictP_def by simp

lemma restrictP_empty [simp]: "R |` {} = (λ_ _. False)"
by(simp add: restrictP_def[abs_def])

lemma refl_on_restrictPI:
  "refl_onP A r  refl_onP (A  B) (r |` B)"
by(rule refl_onPI)(blast dest: refl_onPD1 refl_onPD2 refl_onPD)+

lemma refl_on_restrictPI':
  " refl_onP A r; B = A  C   refl_onP B (r |` C)"
by(simp add: refl_on_restrictPI)

lemma antisym_restrictPI:
  "antisymp r  antisymp (r |` A)"
by(rule antisymPI)(blast dest: antisymPD)

lemma trans_restrictPI:
  "transp r  transp (r |` A)"
by(rule transPI)(blast dest: transPD)

lemma porder_on_restrictPI:
  "porder_on A r  porder_on (A  B) (r |` B)"
by(blast elim: porder_onE intro: refl_on_restrictPI antisym_restrictPI trans_restrictPI porder_onI)

lemma porder_on_restrictPI':
  " porder_on A r; B = A  C   porder_on B (r |` C)"
by(simp add: porder_on_restrictPI)

lemma total_on_restrictPI:
  "total_onP A r  total_onP (A  B) (r |` B)"
by(blast intro: total_onPI dest: total_onPD)

lemma total_on_restrictPI':
  " total_onP A r; B = A  C   total_onP B (r |` C)"
by(simp add: total_on_restrictPI)

lemma torder_on_restrictPI:
  "torder_on A r  torder_on (A  B) (r |` B)"
by(blast elim: torder_onE intro: torder_onI porder_on_restrictPI total_on_restrictPI)

lemma torder_on_restrictPI':
  " torder_on A r; B = A  C   torder_on B (r |` C)"
by(simp add: torder_on_restrictPI)

lemma restrictP_commute:
  fixes r :: "'a  'a  bool"
  shows "r |` A |` B = r |` B |` A"
by(blast intro!: ext)

lemma restrictP_subsume1:
  fixes r :: "'a  'a  bool"
  assumes "A  B"
  shows "r |` A |` B = r |` A"
using assms by(blast intro!: ext)

lemma restrictP_subsume2:
  fixes r :: "'a  'a  bool"
  assumes "B  A"
  shows "r |` A |` B = r |` B"
using assms by(blast intro!: ext)

lemma restrictP_idem [simp]:
  fixes r :: "'a  'a  bool"
  shows "r |` A |` A = r |` A"
by(simp add: restrictP_subsume1)

subsection ‹Maximal elements w.r.t. a total order›

definition max_torder :: "('a  'a  bool)  'a  'a  'a"
where "max_torder r a b = (if Domainp r a  Domainp r b then if r a b then b else a
  else if a = b then a else SOME a. ¬ Domainp r a)"

lemma refl_on_DomainD: "refl_on A r  A = Domain r"
by(auto simp add: Domain_unfold dest: refl_onD refl_onD1)

lemma refl_onP_DomainPD: "refl_onP A r  A = {a. Domainp r a}"
by(drule refl_on_DomainD) auto

lemma semilattice_max_torder:
  assumes tot: "torder_on A r"
  shows "semilattice (max_torder r)"
proof -
  from tot have as: "antisymp r" 
    and to: "total_onP A r" 
    and trans: "transp r"
    and refl: "refl_onP A r" 
    by(auto elim: torder_onE porder_onE)
  from refl have "{a. Domainp r a} = A" by (rule refl_onP_DomainPD[symmetric])
  from this [symmetric] have "domain": "a. Domainp r a  a  A" by simp
  show ?thesis
  proof
    fix x y z
    show "max_torder r (max_torder r x y) z = max_torder r x (max_torder r y z)"
    proof (cases "x  y  x  z  y  z")
      case True
      have *: "a b. a  b  max_torder r a b = (if Domainp r a  Domainp r b then
        if r a b then b else a else SOME a. ¬ Domainp r a)"
        by (auto simp add: max_torder_def)
      with True show ?thesis
        apply (simp only: max_torder_def "domain")
        apply (auto split!: if_splits)
        apply (blast dest: total_onPD [OF to] transPD [OF trans] antisymPD [OF as] refl_onPD1 [OF refl] refl_onPD2 [OF refl] someI [where P="λa. a  A"])+
        done
    next
      have max_torder_idem: "a. max_torder r a a = a" by (simp add: max_torder_def)
      case False then show ?thesis
        apply (auto simp add: max_torder_idem)
        apply (auto simp add: max_torder_def "domain" dest: someI [where P="λa. a  A"])
        done
    qed
  next
    fix x y
    show "max_torder r x y = max_torder r y x"
      by (auto simp add: max_torder_def "domain" dest: total_onPD [OF to] antisymPD [OF as])
  next
    fix x
    show "max_torder r x x = x"
      by (simp add: max_torder_def)
  qed
qed

lemma max_torder_ge_conv_disj:
  assumes tot: "torder_on A r" and x: "x  A" and y: "y  A"
  shows "r z (max_torder r x y)  r z x  r z y"
proof -
  from tot have as: "antisymp r" 
    and to: "total_onP A r" 
    and trans: "transp r"
    and refl: "refl_onP A r" 
    by(auto elim: torder_onE porder_onE)
  from refl have "{a. Domainp r a} = A" by (rule refl_onP_DomainPD[symmetric])
  from this [symmetric] have "domain": "a. Domainp r a  a  A" by simp
  show ?thesis using x y
    by(simp add: max_torder_def "domain")(blast dest: total_onPD[OF to] transPD[OF trans])
qed

definition Max_torder :: "('a  'a  bool)  'a set  'a"
where
  "Max_torder r = semilattice_set.F (max_torder r)"

context
  fixes A r
  assumes tot: "torder_on A r"
begin

lemma semilattice_set:
  "semilattice_set (max_torder r)"
  by (rule semilattice_set.intro, rule semilattice_max_torder) (fact tot)

lemma domain:
  "Domainp r a  a  A"
proof -
  from tot have "{a. Domainp r a} = A"
    by (auto elim: torder_onE porder_onE dest: refl_onP_DomainPD [symmetric])
  from this [symmetric] show ?thesis by simp
qed

lemma Max_torder_in_Domain:
  assumes B: "finite B" "B  {}" "B  A"
  shows "Max_torder r B  A"
proof -
  interpret Max_torder: semilattice_set "max_torder r"
  rewrites
    "semilattice_set.F (max_torder r) = Max_torder r"
    by (fact semilattice_set Max_torder_def [symmetric])+
  show ?thesis using B
    by (induct rule: finite_ne_induct) (simp_all add: max_torder_def "domain")
qed

lemma Max_torder_in_set:
  assumes B: "finite B" "B  {}" "B  A"
  shows "Max_torder r B  B"
proof -
  interpret Max_torder: semilattice_set "max_torder r"
  rewrites
    "semilattice_set.F (max_torder r) = Max_torder r"
    by (fact semilattice_set Max_torder_def [symmetric])+
  show ?thesis using B
    by (induct rule: finite_ne_induct) (auto simp add: max_torder_def "domain")
qed

lemma Max_torder_above_iff:
  assumes B: "finite B" "B  {}" "B  A"
  shows "r x (Max_torder r B)  (aB. r x a)"
proof -
  interpret Max_torder: semilattice_set "max_torder r"
  rewrites
    "semilattice_set.F (max_torder r) = Max_torder r"
    by (fact semilattice_set Max_torder_def [symmetric])+
  from B show ?thesis
    by (induct rule: finite_ne_induct) (simp_all add: max_torder_ge_conv_disj [OF tot] Max_torder_in_Domain)
qed

end

lemma Max_torder_above:
  assumes tot: "torder_on A r"
  and "finite B" "a  B" "B  A"
  shows "r a (Max_torder r B)"
proof -
  from tot have refl: "refl_onP A r" by(auto elim: torder_onE porder_onE)
  with a  B B  A have "r a a" by(blast dest: refl_onPD[OF refl])
  from a  B have "B  {}" by auto
  from Max_torder_above_iff [OF tot ‹finite B this B  A, of a] r a a a  B
  show ?thesis by blast
qed

lemma inv_imageP_id [simp]: "inv_imageP R id = R"
by(simp add: fun_eq_iff)

lemma inv_into_id [simp]: "a  A  inv_into A id a = a"
by (metis f_inv_into_f id_apply image_id)

end

Theory JMM_Spec

(*  Title:      JinjaThreads/MM/JMM_Spec.thy
    Author:     Andreas Lochbihler
*)

section ‹Axiomatic specification of the JMM›

theory JMM_Spec
imports
  Orders
  "../Common/Observable_Events"
  Coinductive.Coinductive_List
begin

subsection ‹Definitions›

type_synonym JMM_action = nat
type_synonym ('addr, 'thread_id) execution = "('thread_id × ('addr, 'thread_id) obs_event action) llist"

definition "actions" :: "('addr, 'thread_id) execution  JMM_action set"
where "actions E = {n. enat n < llength E}"

definition action_tid :: "('addr, 'thread_id) execution  JMM_action  'thread_id"
where "action_tid E a = fst (lnth E a)"

definition action_obs :: "('addr, 'thread_id) execution  JMM_action  ('addr, 'thread_id) obs_event action"
where "action_obs E a = snd (lnth E a)"

definition tactions :: "('addr, 'thread_id) execution  'thread_id  JMM_action set"
where "tactions E t = {a. a  actions E  action_tid E a = t}"

inductive is_new_action :: "('addr, 'thread_id) obs_event action  bool"
where
  NewHeapElem: "is_new_action (NormalAction (NewHeapElem a hT))"

inductive is_write_action :: "('addr, 'thread_id) obs_event action  bool"
where
  NewHeapElem: "is_write_action (NormalAction (NewHeapElem ad hT))"
| WriteMem: "is_write_action (NormalAction (WriteMem ad al v))"

text ‹
  Initialisation actions are synchronisation actions iff they initialize volatile
  fields -- cf. JMM mailing list, message no. 62 (5 Nov. 2006).
  However, intuitively correct programs might not be correctly synchronized:
\begin{verbatim}
     x = 0
---------------
r1 = x | r2 = x
\end{verbatim}
  Here, if x is not volatile, the initial write can belong to at most one thread.
  Hence, it is happens-before to either r1 = x or r2 = x, but not both.
  In any sequentially consistent execution, both reads must read from the initilisation
  action x = 0, but it is not happens-before ordered to one of them.

  Moreover, if only volatile initialisations synchronize-with all thread-start actions,
  this breaks the proof of the DRF guarantee since it assumes that the happens-before relation
  $<=hb$ a for an action $a$ in a topologically sorted action sequence depends only on the 
  actions before it. Counter example: (y is volatile)

  [(t1, start), (t1, init x), (t2, start), (t1, init y), ...

  Here, (t1, init x) $<=hb$ (t2, start) via: (t1, init x) $<=po$ (t1, init y) $<=sw$ (t2, start),
  but in [(t1, start), (t1, init x), (t2, start)], not (t1, init x) $<=hb$ (t2, start).

  Sevcik speculated that one might add an initialisation thread which performs all initialisation
  actions. All normal threads' start action would then synchronize on the final action of the initialisation thread.
  However, this contradicts the memory chain condition in the final field extension to the JMM
  (threads must read addresses of objects that they have not created themselves before they can
  access the fields of the object at that address) -- not modelled here.

  Instead, we leave every initialisation action in the thread it belongs to, but order it explicitly
  before the thread's start action and add synchronizes-with edges from \emph{all} initialisation
  actions to \emph{all} thread start actions.
›

inductive saction :: "'m prog  ('addr, 'thread_id) obs_event action  bool"
for P :: "'m prog"
where
  NewHeapElem: "saction P (NormalAction (NewHeapElem a hT))"
| Read: "is_volatile P al  saction P (NormalAction (ReadMem a al v))"
| Write: "is_volatile P al  saction P (NormalAction (WriteMem a al v))"
| ThreadStart: "saction P (NormalAction (ThreadStart t))"
| ThreadJoin: "saction P (NormalAction (ThreadJoin t))"
| SyncLock: "saction P (NormalAction (SyncLock a))"
| SyncUnlock: "saction P (NormalAction (SyncUnlock a))"
| ObsInterrupt: "saction P (NormalAction (ObsInterrupt t))"
| ObsInterrupted: "saction P (NormalAction (ObsInterrupted t))"
| InitialThreadAction: "saction P InitialThreadAction"
| ThreadFinishAction: "saction P ThreadFinishAction"


definition sactions :: "'m prog  ('addr, 'thread_id) execution  JMM_action set"
where "sactions P E = {a. a  actions E  saction P (action_obs E a)}"

inductive_set write_actions :: "('addr, 'thread_id) execution  JMM_action set"
for E :: "('addr, 'thread_id) execution"
where 
  write_actionsI: " a  actions E; is_write_action (action_obs E a)   a  write_actions E"

text @{term NewObj} and @{term NewArr} actions only initialize those fields and array cells that
  are in fact in the object or array. Hence, they are not a write for
  - reads from addresses for which no object/array is created during the whole execution
  - reads from fields/cells that are not part of the object/array at the specified address.
›

primrec addr_locs :: "'m prog  htype  addr_loc set"
where 
  "addr_locs P (Class_type C) = {CField D F|D F. fm T. P  C has F:T (fm) in D}"
| "addr_locs P (Array_type T n) = ({ACell n'|n'. n' < n}  {CField Object F|F. fm T. P  Object has F:T (fm) in Object})"

text action_loc_aux› would naturally be an inductive set,
  but inductive\_set does not allow to pattern match on parameters.
  Hence, specify it using function and derive the setup manually.
›

fun action_loc_aux :: "'m prog  ('addr, 'thread_id) obs_event action  ('addr × addr_loc) set"
where
  "action_loc_aux P (NormalAction (NewHeapElem ad (Class_type C))) = 
  {(ad, CField D F)|D F T fm. P  C has F:T (fm) in D}"
| "action_loc_aux P (NormalAction (NewHeapElem ad (Array_type T n'))) = 
  {(ad, ACell n)|n. n < n'}  {(ad, CField D F)|D F T fm. P  Object has F:T (fm) in D}"
| "action_loc_aux P (NormalAction (WriteMem ad al v)) = {(ad, al)}"
| "action_loc_aux P (NormalAction (ReadMem ad al v)) = {(ad, al)}"
| "action_loc_aux _ _ = {}"

lemma action_loc_aux_intros [intro?]:
  "P  class_type_of hT has F:T (fm) in D  (ad, CField D F)  action_loc_aux P (NormalAction (NewHeapElem ad hT))"
  "n < n'  (ad, ACell n)  action_loc_aux P (NormalAction (NewHeapElem ad (Array_type T n')))"
  "(ad, al)  action_loc_aux P (NormalAction (WriteMem ad al v))"
  "(ad, al)  action_loc_aux P (NormalAction (ReadMem ad al v))"
by(cases hT) auto

lemma action_loc_aux_cases [elim?, cases set: action_loc_aux]:
  assumes "adal  action_loc_aux P obs"
  obtains (NewHeapElem) hT F T fm D ad where "obs = NormalAction (NewHeapElem ad hT)" "adal = (ad, CField D F)" "P  class_type_of hT has F:T (fm) in D"
  | (NewArr) n n' ad T where "obs = NormalAction (NewHeapElem ad (Array_type T n'))" "adal = (ad, ACell n)" "n < n'"
  | (WriteMem) ad al v where "obs = NormalAction (WriteMem ad al v)" "adal = (ad, al)"
  | (ReadMem) ad al v where "obs = NormalAction (ReadMem ad al v)" "adal = (ad, al)"
using assms by(cases "(P, obs)" rule: action_loc_aux.cases) fastforce+

lemma action_loc_aux_simps [simp]:
  "(ad', al')  action_loc_aux P (NormalAction (NewHeapElem ad hT))  
   (D F T fm. ad = ad'  al' = CField D F  P  class_type_of hT has F:T (fm) in D)  
   (n T n'. ad = ad'  al' = ACell n  hT = Array_type T n'  n < n')"
  "(ad', al')  action_loc_aux P (NormalAction (WriteMem ad al v))  ad = ad'  al = al'"
  "(ad', al')  action_loc_aux P (NormalAction (ReadMem ad al v))  ad = ad'  al = al'"
  "(ad', al')  action_loc_aux P InitialThreadAction"
  "(ad', al')  action_loc_aux P ThreadFinishAction"
  "(ad', al')  action_loc_aux P (NormalAction (ExternalCall a m vs v))"
  "(ad', al')  action_loc_aux P (NormalAction (ThreadStart t))"
  "(ad', al')  action_loc_aux P (NormalAction (ThreadJoin t))"
  "(ad', al')  action_loc_aux P (NormalAction (SyncLock a))"
  "(ad', al')  action_loc_aux P (NormalAction (SyncUnlock a))"
  "(ad', al')  action_loc_aux P (NormalAction (ObsInterrupt t))"
  "(ad', al')  action_loc_aux P (NormalAction (ObsInterrupted t))"
by(cases hT) auto

declare action_loc_aux.simps [simp del]

abbreviation action_loc :: "'m prog  ('addr, 'thread_id) execution  JMM_action  ('addr × addr_loc) set"
where "action_loc P E a  action_loc_aux P (action_obs E a)"

inductive_set read_actions :: "('addr, 'thread_id) execution  JMM_action set"
for E :: "('addr, 'thread_id) execution"
where 
  ReadMem: " a  actions E; action_obs E a = NormalAction (ReadMem ad al v)   a  read_actions E"

fun addr_loc_default :: "'m prog  htype  addr_loc  'addr val"
where
  "addr_loc_default P (Class_type C) (CField D F) = default_val (fst (the (map_of (fields P C) (F, D))))"
| "addr_loc_default P (Array_type T n) (ACell n') = default_val T"
| addr_loc_default_Array_CField: 
  "addr_loc_default P (Array_type T n) (CField D F) = default_val (fst (the (map_of (fields P Object) (F, Object))))"
| "addr_loc_default P _ _ = undefined"

definition new_actions_for :: "'m prog  ('addr, 'thread_id) execution  ('addr × addr_loc)  JMM_action set"
where 
  "new_actions_for P E adal =
   {a. a  actions E  adal  action_loc P E a  is_new_action (action_obs E a)}"

inductive_set external_actions :: "('addr, 'thread_id) execution  JMM_action set"
for E :: "('addr, 'thread_id) execution"
where
  " a  actions E; action_obs E a = NormalAction (ExternalCall ad M vs v)  
   a  external_actions E"

fun value_written_aux :: "'m prog  ('addr, 'thread_id) obs_event action  addr_loc  'addr val"
where
  "value_written_aux P (NormalAction (NewHeapElem ad' hT)) al = addr_loc_default P hT al"
| value_written_aux_WriteMem':
  "value_written_aux P (NormalAction (WriteMem ad al' v)) al = (if al = al' then v else undefined)"
| value_written_aux_undefined:
  "value_written_aux P _ al = undefined"

primrec value_written :: "'m prog  ('addr, 'thread_id) execution  JMM_action  ('addr × addr_loc)  'addr val"
where "value_written P E a (ad, al) = value_written_aux P (action_obs E a) al"

definition value_read :: "('addr, 'thread_id) execution  JMM_action  'addr val"
where
  "value_read E a = 
  (case action_obs E a of
     NormalAction obs 
        (case obs of
           ReadMem ad al v  v
         | _  undefined)
   | _  undefined)"

definition action_order :: "('addr, 'thread_id) execution  JMM_action  JMM_action  bool" ("_  _ ≤a _" [51,0,50] 50)
where
  "E  a ≤a a' 
   a  actions E  a'  actions E  
   (if is_new_action (action_obs E a)
    then is_new_action (action_obs E a')  a  a'
    else ¬ is_new_action (action_obs E a')  a  a')"

definition program_order :: "('addr, 'thread_id) execution  JMM_action  JMM_action  bool" ("_  _ ≤po _" [51,0,50] 50)
where
  "E  a ≤po a'  E  a ≤a a'  action_tid E a = action_tid E a'"

inductive synchronizes_with :: 
  "'m prog 
   ('thread_id × ('addr, 'thread_id) obs_event action)  ('thread_id × ('addr, 'thread_id) obs_event action)  bool" 
  ("_  _ ↝sw _" [51, 51, 51] 50)
  for P :: "'m prog"
where
  ThreadStart: "P  (t, NormalAction (ThreadStart t')) ↝sw (t', InitialThreadAction)"
| ThreadFinish: "P  (t, ThreadFinishAction) ↝sw (t', NormalAction (ThreadJoin t))"
| UnlockLock: "P  (t, NormalAction (SyncUnlock a)) ↝sw (t', NormalAction (SyncLock a))"
| ― ‹Only volatile writes synchronize with volatile reads. 
       We could check volatility of @{term "al"} here, but this is checked by @{term "sactions"}
       in @{text sync_with} anyway.›
  Volatile: "P  (t, NormalAction (WriteMem a al v)) ↝sw (t', NormalAction (ReadMem a al v'))"
| VolatileNew: "
    al  addr_locs P hT
     P  (t, NormalAction (NewHeapElem a hT)) ↝sw (t', NormalAction (ReadMem a al v))"
| NewHeapElem: "P  (t, NormalAction (NewHeapElem a hT)) ↝sw (t', InitialThreadAction)"
| Interrupt: "P  (t, NormalAction (ObsInterrupt t')) ↝sw (t'', NormalAction (ObsInterrupted t'))"

definition sync_order :: 
  "'m prog  ('addr, 'thread_id) execution  JMM_action  JMM_action  bool"
  ("_,_  _ ≤so _" [51,0,0,50] 50)
where
  "P,E  a ≤so a'  a  sactions P E  a'  sactions P E  E  a ≤a a'"

definition sync_with :: 
  "'m prog  ('addr, 'thread_id) execution  JMM_action  JMM_action  bool"
  ("_,_  _ ≤sw _" [51, 0, 0, 50] 50)
where
  "P,E  a ≤sw a' 
   P,E  a ≤so a'  P  (action_tid E a, action_obs E a) ↝sw (action_tid E a', action_obs E a')"

definition po_sw :: "'m prog  ('addr, 'thread_id) execution  JMM_action  JMM_action  bool"
where "po_sw P E a a'  E  a ≤po a'  P,E  a ≤sw a'"

abbreviation happens_before :: 
  "'m prog  ('addr, 'thread_id) execution  JMM_action  JMM_action  bool"
  ("_,_  _ ≤hb _" [51, 0, 0, 50] 50)
where "happens_before P E  (po_sw P E)^++"

type_synonym write_seen = "JMM_action  JMM_action"

definition is_write_seen :: "'m prog  ('addr, 'thread_id) execution  write_seen  bool" where 
  "is_write_seen P E ws 
   (a  read_actions E. ad al v. action_obs E a = NormalAction (ReadMem ad al v)  
       ws a  write_actions E  (ad, al)  action_loc P E (ws a) 
       value_written P E (ws a) (ad, al) = v  ¬ P,E  a ≤hb ws a 
       (is_volatile P al  ¬ P,E  a ≤so ws a) 
       (w'  write_actions E. (ad, al)  action_loc P E w'  
          (P,E  ws a ≤hb w'  P,E  w' ≤hb a  is_volatile P al  P,E  ws a ≤so w'  P,E  w' ≤so a) 
          w' = ws a))"

definition thread_start_actions_ok :: "('addr, 'thread_id) execution  bool"
where
  "thread_start_actions_ok E  
  (a  actions E. ¬ is_new_action (action_obs E a)  
     (i. i  a  action_obs E i = InitialThreadAction  action_tid E i = action_tid E a))"

primrec wf_exec :: "'m prog  ('addr, 'thread_id) execution × write_seen  bool" ("_  _ " [51, 50] 51)
where "P  (E, ws)   is_write_seen P E ws  thread_start_actions_ok E"

inductive most_recent_write_for :: "'m prog  ('addr, 'thread_id) execution  JMM_action  JMM_action  bool"
  ("_,_  _ ↝mrw _" [50, 0, 51] 51)
for P :: "'m prog" and E :: "('addr, 'thread_id) execution" and ra :: JMM_action and wa :: JMM_action
where
  " ra  read_actions E; adal  action_loc P E ra; E  wa ≤a ra;
     wa  write_actions E; adal  action_loc P E wa;
     wa'.  wa'  write_actions E; adal  action_loc P E wa' 
      E  wa' ≤a wa  E  ra ≤a wa' 
   P,E  ra ↝mrw wa"

primrec sequentially_consistent :: "'m prog  (('addr, 'thread_id) execution × write_seen)  bool"
where 
  "sequentially_consistent P (E, ws)  (r  read_actions E. P,E  r ↝mrw ws r)"


subsection ‹Actions›

inductive_cases is_new_action_cases [elim!]:
  "is_new_action (NormalAction (ExternalCall a M vs v))"
  "is_new_action (NormalAction (ReadMem a al v))"
  "is_new_action (NormalAction (WriteMem a al v))"
  "is_new_action (NormalAction (NewHeapElem a hT))"
  "is_new_action (NormalAction (ThreadStart t))"
  "is_new_action (NormalAction (ThreadJoin t))"
  "is_new_action (NormalAction (SyncLock a))"
  "is_new_action (NormalAction (SyncUnlock a))"
  "is_new_action (NormalAction (ObsInterrupt t))"
  "is_new_action (NormalAction (ObsInterrupted t))"
  "is_new_action InitialThreadAction"
  "is_new_action ThreadFinishAction"

inductive_simps is_new_action_simps [simp]:
  "is_new_action (NormalAction (NewHeapElem a hT))"
  "is_new_action (NormalAction (ExternalCall a M vs v))"
  "is_new_action (NormalAction (ReadMem a al v))"
  "is_new_action (NormalAction (WriteMem a al v))"
  "is_new_action (NormalAction (ThreadStart t))"
  "is_new_action (NormalAction (ThreadJoin t))"
  "is_new_action (NormalAction (SyncLock a))"
  "is_new_action (NormalAction (SyncUnlock a))"
  "is_new_action (NormalAction (ObsInterrupt t))"
  "is_new_action (NormalAction (ObsInterrupted t))"
  "is_new_action InitialThreadAction"
  "is_new_action ThreadFinishAction"

lemmas is_new_action_iff = is_new_action.simps

inductive_simps is_write_action_simps [simp]:
  "is_write_action InitialThreadAction"
  "is_write_action ThreadFinishAction"
  "is_write_action (NormalAction (ExternalCall a m vs v))"
  "is_write_action (NormalAction (ReadMem a al v))"
  "is_write_action (NormalAction (WriteMem a al v))"
  "is_write_action (NormalAction (NewHeapElem a hT))"
  "is_write_action (NormalAction (ThreadStart t))"
  "is_write_action (NormalAction (ThreadJoin t))"
  "is_write_action (NormalAction (SyncLock a))"
  "is_write_action (NormalAction (SyncUnlock a))"
  "is_write_action (NormalAction (ObsInterrupt t))"
  "is_write_action (NormalAction (ObsInterrupted t))"

declare saction.intros [intro!]

inductive_cases saction_cases [elim!]:
  "saction P (NormalAction (ExternalCall a M vs v))"
  "saction P (NormalAction (ReadMem a al v))"
  "saction P (NormalAction (WriteMem a al v))"
  "saction P (NormalAction (NewHeapElem a hT))"
  "saction P (NormalAction (ThreadStart t))"
  "saction P (NormalAction (ThreadJoin t))"
  "saction P (NormalAction (SyncLock a))"
  "saction P (NormalAction (SyncUnlock a))"
  "saction P (NormalAction (ObsInterrupt t))"
  "saction P (NormalAction (ObsInterrupted t))"
  "saction P InitialThreadAction"
  "saction P ThreadFinishAction"

inductive_simps saction_simps [simp]:
  "saction P (NormalAction (ExternalCall a M vs v))"
  "saction P (NormalAction (ReadMem a al v))"
  "saction P (NormalAction (WriteMem a al v))"
  "saction P (NormalAction (NewHeapElem a hT))"
  "saction P (NormalAction (ThreadStart t))"
  "saction P (NormalAction (ThreadJoin t))"
  "saction P (NormalAction (SyncLock a))"
  "saction P (NormalAction (SyncUnlock a))"
  "saction P (NormalAction (ObsInterrupt t))"
  "saction P (NormalAction (ObsInterrupted t))"
  "saction P InitialThreadAction"
  "saction P ThreadFinishAction"

lemma new_action_saction [simp, intro]: "is_new_action a  saction P a"
by(blast elim: is_new_action.cases)

lemmas saction_iff = saction.simps

lemma actionsD: "a  actions E  enat a < llength E"
unfolding actions_def by blast

lemma actionsE: 
  assumes "a  actions E"
  obtains "enat a < llength E"
using assms unfolding actions_def by blast

lemma actions_lappend:
  "llength xs = enat n  actions (lappend xs ys) = actions xs  ((+) n) ` actions ys"
unfolding actions_def
apply safe
  apply(erule contrapos_np)
  apply(rule_tac x="x - n" in image_eqI)
   apply simp_all
  apply(case_tac [!] "llength ys")
 apply simp_all
done

lemma tactionsE:
  assumes "a  tactions E t"
  obtains obs where "a  actions E" "action_tid E a = t" "action_obs E a = obs"
using assms
by(cases "lnth E a")(auto simp add: tactions_def action_tid_def action_obs_def)

lemma sactionsI:
  " a  actions E; saction P (action_obs E a)   a  sactions P E"
unfolding sactions_def by blast

lemma sactionsE:
  assumes "a  sactions P E"
  obtains "a  actions E" "saction P (action_obs E a)"
using assms unfolding sactions_def by blast

lemma sactions_actions [simp]:
  "a  sactions P E  a  actions E"
by(rule sactionsE)

lemma value_written_aux_WriteMem [simp]:
  "value_written_aux P (NormalAction (WriteMem ad al v)) al = v"
by simp

declare value_written_aux_undefined [simp del]
declare value_written_aux_WriteMem' [simp del]

inductive_simps is_write_action_iff:
  "is_write_action a"

inductive_simps write_actions_iff:
  "a  write_actions E"

lemma write_actions_actions [simp]:
  "a  write_actions E  a  actions E"
by(rule write_actions.induct)

inductive_simps read_actions_iff:
  "a  read_actions E"

lemma read_actions_actions [simp]:
  "a  read_actions E  a  actions E"
by(rule read_actions.induct)

lemma read_action_action_locE:
  assumes "r  read_actions E"
  obtains ad al where "(ad, al)  action_loc P E r"
using assms by cases auto

lemma read_actions_not_write_actions:
  " a  read_actions E; a  write_actions E   False"
by(auto elim!: read_actions.cases write_actions.cases)

lemma read_actions_Int_write_actions [simp]:
  "read_actions E  write_actions E = {}"
  "write_actions E  read_actions E = {}"
by(blast dest: read_actions_not_write_actions)+

lemma action_loc_addr_fun:
  " (ad, al)  action_loc P E a; (ad', al')  action_loc P E a   ad = ad'"
by(auto elim!: action_loc_aux_cases)

lemma value_written_cong [cong]:
  " P = P'; a = a'; action_obs E a' = action_obs E' a'  
   value_written P E a = value_written P' E' a'"
by(rule ext)(auto split: action.splits)

declare value_written.simps [simp del]

lemma new_actionsI:
  " a  actions E; adal  action_loc P E a; is_new_action (action_obs E a) 
   a  new_actions_for P E adal"
unfolding new_actions_for_def by blast

lemma new_actionsE:
  assumes "a  new_actions_for P E adal"
  obtains "a  actions E" "adal  action_loc P E a" "is_new_action (action_obs E a)"
using assms unfolding new_actions_for_def by blast

lemma action_loc_read_action_singleton:
  " r  read_actions E; adal  action_loc P E r; adal'  action_loc P E r   adal = adal'"
by(cases adal, cases adal')(fastforce elim: read_actions.cases action_loc_aux_cases)

lemma addr_locsI:
  "P  class_type_of hT has F:T (fm) in D  CField D F  addr_locs P hT"
  " hT = Array_type T n; n' < n   ACell n'  addr_locs P hT"
by(cases hT)(auto dest: has_field_decl_above)

subsection ‹Orders›
subsection ‹Action order›

lemma action_orderI:
  assumes "a  actions E" "a'  actions E"
  and " is_new_action (action_obs E a); is_new_action (action_obs E a')   a  a'"
  and "¬ is_new_action (action_obs E a)  ¬ is_new_action (action_obs E a')  a  a'"
  shows "E  a ≤a a'"
using assms unfolding action_order_def by simp

lemma action_orderE:
  assumes "E  a ≤a a'"
  obtains "a  actions E" "a'  actions E" 
          "is_new_action (action_obs E a)" "is_new_action (action_obs E a')  a  a'"
        | "a  actions E" "a'  actions E" 
          "¬ is_new_action (action_obs E a)" "¬ is_new_action (action_obs E a')" "a  a'"
using assms unfolding action_order_def by(simp split: if_split_asm)

lemma refl_action_order:
  "refl_onP (actions E) (action_order E)"
by(rule refl_onPI)(auto elim: action_orderE intro: action_orderI)

lemma antisym_action_order:
  "antisymp (action_order E)"
by(rule antisympI)(auto elim!: action_orderE)

lemma trans_action_order:
  "transp (action_order E)"
by(rule transpI)(auto elim!: action_orderE intro: action_orderI)

lemma porder_action_order:
  "porder_on (actions E) (action_order E)"
by(blast intro: porder_onI refl_action_order antisym_action_order trans_action_order)

lemma total_action_order:
  "total_onP (actions E) (action_order E)"
by(rule total_onPI)(auto simp add: action_order_def)

lemma torder_action_order:
  "torder_on (actions E) (action_order E)"
by(blast intro: torder_onI total_action_order porder_action_order)

lemma wf_action_order: "wfP (action_order E)"
unfolding wfP_eq_minimal
proof(intro strip)
  fix Q and x :: JMM_action
  assume "x  Q"
  show "z  Q. y. (action_order E) y z  y  Q"
  proof(cases "a  Q. a  actions E  is_new_action (action_obs E a)")
    case True
    then obtain a where a: "a  actions E  is_new_action (action_obs E a)  a  Q" by blast
    define a' where "a' = (LEAST a'. a'  actions E  is_new_action (action_obs E a')  a'  Q)"
    from a have a': "a'  actions E  is_new_action (action_obs E a')  a'  Q"
      unfolding a'_def by(rule LeastI)
    { fix y
      assume y_le_a': "(action_order E) y a'"
      have "y  Q"
      proof
        assume "y  Q"
        with y_le_a' a' have y: "y  actions E  is_new_action (action_obs E y)  y  Q"
          by(auto elim: action_orderE)
        hence "a'  y" unfolding a'_def by(rule Least_le)
        with y_le_a' a' show False by(auto elim: action_orderE)
      qed }
    with a' show ?thesis by blast
  next
    case False
    hence not_new: "a.  a  Q; a  actions E   ¬ is_new_action (action_obs E a)" by blast
    show ?thesis
    proof(cases "Q  actions E = {}")
      case True
      with x  Q show ?thesis by(auto elim: action_orderE)
    next
      case False
      define a' where "a' = (LEAST a'. a'  Q  a'  actions E  ¬ is_new_action (action_obs E a'))"
      from False obtain a where "a  Q" "a  actions E" by blast
      with not_new[OF this] have "a  Q  a  actions E  ¬ is_new_action (action_obs E a)" by blast
      hence a': "a'  Q  a'  actions E  ¬ is_new_action (action_obs E a')"
        unfolding a'_def by(rule LeastI)
      { fix y
        assume y_le_a': "(action_order E) y a'"
        hence "y  actions E" by(auto elim: action_orderE)
        have "y  Q"
        proof
          assume "y  Q"
          hence y_not_new: "¬ is_new_action (action_obs E y)"
            using y  actions E by(rule not_new)
          with y  Q y  actions E have "a'  y"
            unfolding a'_def by -(rule Least_le, blast)
          with y_le_a' y_not_new show False by(auto elim: action_orderE)
        qed }
      with a' show ?thesis by blast
    qed
  qed
qed

lemma action_order_is_new_actionD:
  " E  a ≤a a'; is_new_action (action_obs E a')   is_new_action (action_obs E a)"
by(auto elim: action_orderE)

subsection ‹Program order›

lemma program_orderI:
  assumes "E  a ≤a a'" and "action_tid E a = action_tid E a'"
  shows "E  a ≤po a'"
using assms unfolding program_order_def by auto

lemma program_orderE:
  assumes "E  a ≤po a'"
  obtains t obs obs'
  where "E  a ≤a a'"
  and "action_tid E a = t" "action_obs E a = obs"
  and "action_tid E a' = t" "action_obs E a' = obs'"
using assms unfolding program_order_def
by(cases "lnth E a")(cases "lnth E a'", auto simp add: action_obs_def action_tid_def)

lemma refl_on_program_order:
  "refl_onP (actions E) (program_order E)"
by(rule refl_onPI)(auto elim: action_orderE program_orderE intro: program_orderI refl_onPD[OF refl_action_order])

lemma antisym_program_order:
  "antisymp (program_order E)"
using antisympD[OF antisym_action_order]
by(auto intro: antisympI elim!: program_orderE)

lemma trans_program_order:
  "transp (program_order E)"
by(rule transpI)(auto elim!: program_orderE intro: program_orderI dest: transPD[OF trans_action_order])

lemma porder_program_order:
  "porder_on (actions E) (program_order E)"
by(blast intro: porder_onI refl_on_program_order antisym_program_order trans_program_order)

lemma total_program_order_on_tactions:
  "total_onP (tactions E t) (program_order E)"
by(rule total_onPI)(auto elim: tactionsE simp add: program_order_def dest: total_onD[OF total_action_order])


subsection ‹Synchronization order›

lemma sync_orderI:
  " E  a ≤a a'; a  sactions P E; a'  sactions P E   P,E  a ≤so a'"
unfolding sync_order_def by blast

lemma sync_orderE:
  assumes "P,E  a ≤so a'"
  obtains "a  sactions P E" "a'  sactions P E" "E  a ≤a a'"
using assms unfolding sync_order_def by blast

lemma refl_on_sync_order:
  "refl_onP (sactions P E) (sync_order P E)"
by(rule refl_onPI)(fastforce elim: sync_orderE intro: sync_orderI refl_onPD[OF refl_action_order])+

lemma antisym_sync_order:
  "antisymp (sync_order P E)"
using antisympD[OF antisym_action_order]
by(rule antisympI)(auto elim!: sync_orderE)

lemma trans_sync_order:
  "transp (sync_order P E)"
by(rule transpI)(auto elim!: sync_orderE intro: sync_orderI dest: transPD[OF trans_action_order])

lemma porder_sync_order:
  "porder_on (sactions P E) (sync_order P E)"
by(blast intro: porder_onI refl_on_sync_order antisym_sync_order trans_sync_order)

lemma total_sync_order:
  "total_onP (sactions P E) (sync_order P E)"
apply(rule total_onPI)
apply(simp add: sync_order_def)
apply(rule total_onPD[OF total_action_order])
apply simp_all
done

lemma torder_sync_order:
  "torder_on (sactions P E) (sync_order P E)"
by(blast intro: torder_onI porder_sync_order total_sync_order)

subsection ‹Synchronizes with›

lemma sync_withI:
  " P,E  a ≤so a'; P  (action_tid E a, action_obs E a) ↝sw (action_tid E a', action_obs E a') 
   P,E  a ≤sw a'"
unfolding sync_with_def by blast

lemma sync_withE:
  assumes "P,E  a ≤sw a'"
  obtains "P,E  a ≤so a'" "P  (action_tid E a, action_obs E a) ↝sw (action_tid E a', action_obs E a')"
using assms unfolding sync_with_def by blast

lemma irrefl_synchronizes_with:
  "irreflP (synchronizes_with P)"
by(rule irreflPI)(auto elim: synchronizes_with.cases)

lemma irrefl_sync_with:
  "irreflP (sync_with P E)"
by(rule irreflPI)(auto elim: sync_withE intro: irreflPD[OF irrefl_synchronizes_with])

lemma anitsym_sync_with:
  "antisymp (sync_with P E)"
using antisymPD[OF antisym_sync_order, of P E]
by -(rule antisymPI, auto elim: sync_withE)

lemma consistent_program_order_sync_order:
  "order_consistent (program_order E) (sync_order P E)"
apply(rule order_consistent_subset)
apply(rule antisym_order_consistent_self[OF antisym_action_order[of E]])
apply(blast elim: program_orderE sync_orderE)+
done

lemma consistent_program_order_sync_with:
  "order_consistent (program_order E) (sync_with P E)"
by(rule order_consistent_subset[OF consistent_program_order_sync_order])(blast elim: sync_withE)+

subsection ‹Happens before›

lemma porder_happens_before:
  "porder_on (actions E) (happens_before P E)"
unfolding po_sw_def [abs_def]
by(rule porder_on_sub_torder_on_tranclp_porder_onI[OF porder_program_order torder_sync_order consistent_program_order_sync_order])(auto elim: sync_withE)

lemma porder_tranclp_po_so:
  "porder_on (actions E) (λa a'. program_order E a a'  sync_order P E a a')^++"
by(rule porder_on_torder_on_tranclp_porder_onI[OF porder_program_order torder_sync_order consistent_program_order_sync_order]) auto

lemma happens_before_refl:
  assumes "a  actions E"
  shows "P,E  a ≤hb a"
using porder_happens_before[of E P]
by(rule porder_onE)(erule refl_onPD[OF _ assms])

lemma happens_before_into_po_so_tranclp:
  assumes "P,E  a ≤hb a'"
  shows "(λa a'. E  a ≤po a'  P,E  a ≤so a')^++ a a'"
using assms unfolding po_sw_def [abs_def]
by(induct)(blast elim: sync_withE intro: tranclp.trancl_into_trancl)+

lemma po_sw_into_action_order:
  "po_sw P E a a'  E  a ≤a a'"
by(auto elim: program_orderE sync_withE sync_orderE simp add: po_sw_def)

lemma happens_before_into_action_order:
  assumes "P,E  a ≤hb a'"
  shows "E  a ≤a a'"
using assms
by induct(blast intro: po_sw_into_action_order transPD[OF trans_action_order])+

lemma action_order_consistent_with_happens_before:
  "order_consistent (action_order E) (happens_before P E)"
by(blast intro: order_consistent_subset antisym_order_consistent_self antisym_action_order happens_before_into_action_order)

lemma happens_before_new_actionD:
  assumes hb: "P,E  a ≤hb a'"
  and new: "is_new_action (action_obs E a')"
  shows "is_new_action (action_obs E a)" "action_tid E a = action_tid E a'" "a  a'"
using hb
proof(induct rule: converse_tranclp_induct)
  case (base a)

  case 1 from new base show ?case
    by(auto dest: po_sw_into_action_order elim: action_orderE)
  case 2 from new base show ?case
    by(auto simp add: po_sw_def elim!: sync_withE elim: program_orderE synchronizes_with.cases)
  case 3 from new base show ?case
    by(auto dest: po_sw_into_action_order elim: action_orderE)
next
  case (step a a'')
  
  note po_sw = ‹po_sw P E a a''
    and new = ‹is_new_action (action_obs E a'')
    and tid = ‹action_tid E a'' = action_tid E a'
  
  case 1 from new po_sw show ?case
    by(auto dest: po_sw_into_action_order elim: action_orderE)
  case 2 from new po_sw tid show ?case
    by(auto simp add: po_sw_def elim!: sync_withE elim: program_orderE synchronizes_with.cases)
  case 3 from new po_sw a''  a' show ?case
    by(auto dest!: po_sw_into_action_order elim!: action_orderE)
qed

lemma external_actions_not_new:
  " a  external_actions E; is_new_action (action_obs E a)   False"
by(erule external_actions.cases)(simp)

subsection ‹Most recent writes and sequential consistency›

lemma most_recent_write_for_fun:
  " P,E  ra ↝mrw wa; P,E  ra ↝mrw wa'   wa = wa'"
apply(erule most_recent_write_for.cases)+
apply clarsimp
apply(erule meta_allE)+
apply(erule meta_impE)
 apply(rotate_tac 3)
 apply assumption
apply(erule (1) meta_impE)
apply(frule (1) action_loc_read_action_singleton)
 apply(rotate_tac 1)
 apply assumption
apply(fastforce dest: antisymPD[OF antisym_action_order] elim: write_actions.cases read_actions.cases)
done

lemma THE_most_recent_writeI: "P,E  r ↝mrw w  (THE w. P,E  r ↝mrw w) = w"
by(blast dest: most_recent_write_for_fun)+

lemma most_recent_write_for_write_actionsD:
  assumes "P,E  ra ↝mrw wa"
  shows "wa  write_actions E"
using assms by cases

lemma most_recent_write_recent:
  " P,E  r ↝mrw w; adal  action_loc P E r; w'  write_actions E; adal  action_loc P E w'  
   E  w' ≤a w  E  r ≤a w'"
apply(erule most_recent_write_for.cases)
apply(drule (1) action_loc_read_action_singleton)
 apply(rotate_tac 1)
 apply assumption
apply clarsimp
done

lemma is_write_seenI:
  " a ad al v.  a  read_actions E; action_obs E a = NormalAction (ReadMem ad al v) 
      ws a  write_actions E;
     a ad al v.  a  read_actions E; action_obs E a = NormalAction (ReadMem ad al v) 
      (ad, al)  action_loc P E (ws a);
     a ad al v.  a  read_actions E; action_obs E a = NormalAction (ReadMem ad al v) 
      value_written P E (ws a) (ad, al) = v;
     a ad al v.  a  read_actions E; action_obs E a = NormalAction (ReadMem ad al v) 
      ¬ P,E  a ≤hb ws a;
     a ad al v.  a  read_actions E; action_obs E a = NormalAction (ReadMem ad al v); is_volatile P al 
      ¬ P,E  a ≤so ws a;
     a ad al v a'.  a  read_actions E; action_obs E a = NormalAction (ReadMem ad al v);
                      a'  write_actions E; (ad, al)  action_loc P E a'; P,E  ws a ≤hb a';
                      P,E  a' ≤hb a   a' = ws a;
     a ad al v a'.  a  read_actions E; action_obs E a = NormalAction (ReadMem ad al v);
                      a'  write_actions E; (ad, al)  action_loc P E a'; is_volatile P al; P,E  ws a ≤so a';
                      P,E  a' ≤so a   a' = ws a 
   is_write_seen P E ws"
unfolding is_write_seen_def
by(blast 30)

lemma is_write_seenD:
  " is_write_seen P E ws; a  read_actions E; action_obs E a = NormalAction (ReadMem ad al v) 
   ws a  write_actions E  (ad, al)  action_loc P E (ws a)  value_written P E (ws a) (ad, al) = v  ¬ P,E  a ≤hb ws a  (is_volatile P al  ¬ P,E  a ≤so ws a) 
     (a'  write_actions E. (ad, al)  action_loc P E a'  (P,E  ws a ≤hb a'  P,E  a' ≤hb a  is_volatile P al  P,E  ws a ≤so a'  P,E  a' ≤so a)  a' = ws a)"
unfolding is_write_seen_def by blast

lemma thread_start_actions_okI:
  "(a.  a  actions E; ¬ is_new_action (action_obs E a)  
     i. i  a  action_obs E i = InitialThreadAction  action_tid E i = action_tid E a)
   thread_start_actions_ok E"
unfolding thread_start_actions_ok_def by blast

lemma thread_start_actions_okD:
  " thread_start_actions_ok E; a  actions E; ¬ is_new_action (action_obs E a)  
   i. i  a  action_obs E i = InitialThreadAction  action_tid E i = action_tid E a"
unfolding thread_start_actions_ok_def by blast

lemma thread_start_actions_ok_prefix:
  " thread_start_actions_ok E'; lprefix E E'   thread_start_actions_ok E"
  apply(clarsimp simp add: lprefix_conv_lappend)
  apply(rule thread_start_actions_okI)
  apply(drule_tac a=a in thread_start_actions_okD)
    apply(simp add: actions_def)
    apply(auto simp add: action_obs_def lnth_lappend1 actions_def action_tid_def le_less_trans[where y="enat a" for a])
  apply (metis add.right_neutral add_strict_mono not_gr_zero)
  done

lemma wf_execI [intro?]:
  " is_write_seen P E ws;
    thread_start_actions_ok E 
   P  (E, ws) "
by simp

lemma wf_exec_is_write_seenD:
  "P  (E, ws)   is_write_seen P E ws"
by simp

lemma wf_exec_thread_start_actions_okD:
  "P  (E, ws)   thread_start_actions_ok E"
by simp

lemma sequentially_consistentI:
  "(r. r  read_actions E  P,E  r ↝mrw ws r)
   sequentially_consistent P (E, ws)"
by simp

lemma sequentially_consistentE:
  assumes "sequentially_consistent P (E, ws)" "a  read_actions E"
  obtains "P,E  a ↝mrw ws a"
using assms by simp

declare sequentially_consistent.simps [simp del]

subsection ‹Similar actions›

text ‹Similar actions differ only in the values written/read.›

inductive sim_action :: 
  "('addr, 'thread_id) obs_event action  ('addr, 'thread_id) obs_event action  bool" 
  ("_  _" [50, 50] 51)
where
  InitialThreadAction: "InitialThreadAction  InitialThreadAction"
| ThreadFinishAction: "ThreadFinishAction  ThreadFinishAction"
| NewHeapElem: "NormalAction (NewHeapElem a hT)  NormalAction (NewHeapElem a hT)"
| ReadMem: "NormalAction (ReadMem ad al v)  NormalAction (ReadMem ad al v')"
| WriteMem: "NormalAction (WriteMem ad al v)  NormalAction (WriteMem ad al v')"
| ThreadStart: "NormalAction (ThreadStart t)  NormalAction (ThreadStart t)"
| ThreadJoin: "NormalAction (ThreadJoin t)  NormalAction (ThreadJoin t)"
| SyncLock: "NormalAction (SyncLock a)  NormalAction (SyncLock a)"
| SyncUnlock: "NormalAction (SyncUnlock a)  NormalAction (SyncUnlock a)"
| ExternalCall: "NormalAction (ExternalCall a M vs v)  NormalAction (ExternalCall a M vs v)"
| ObsInterrupt: "NormalAction (ObsInterrupt t)  NormalAction (ObsInterrupt t)"
| ObsInterrupted: "NormalAction (ObsInterrupted t)  NormalAction (ObsInterrupted t)"

definition sim_actions :: "('addr, 'thread_id) execution  ('addr, 'thread_id) execution  bool" ("_ [≈] _" [51, 50] 51)
where "sim_actions = llist_all2 (λ(t, a) (t', a'). t = t'  a  a')"

lemma sim_action_refl [intro!, simp]:
  "obs  obs"
apply(cases obs)
 apply(rename_tac obs')
 apply(case_tac "obs'")
apply(auto intro: sim_action.intros)
done

inductive_cases sim_action_cases [elim!]:
  "InitialThreadAction  obs"
  "ThreadFinishAction  obs"
  "NormalAction (NewHeapElem a hT)  obs"
  "NormalAction (ReadMem ad al v)  obs"
  "NormalAction (WriteMem ad al v)  obs"
  "NormalAction (ThreadStart t)  obs"
  "NormalAction (ThreadJoin t)  obs"
  "NormalAction (SyncLock a)  obs"
  "NormalAction (SyncUnlock a)  obs"
  "NormalAction (ObsInterrupt t)  obs"
  "NormalAction (ObsInterrupted t)  obs"
  "NormalAction (ExternalCall a M vs v)  obs"

  "obs  InitialThreadAction"
  "obs  ThreadFinishAction"
  "obs  NormalAction (NewHeapElem a hT)"
  "obs  NormalAction (ReadMem ad al v')"
  "obs  NormalAction (WriteMem ad al v')"
  "obs  NormalAction (ThreadStart t)"
  "obs  NormalAction (ThreadJoin t)"
  "obs  NormalAction (SyncLock a)"
  "obs  NormalAction (SyncUnlock a)"
  "obs  NormalAction (ObsInterrupt t)"
  "obs  NormalAction (ObsInterrupted t)"
  "obs  NormalAction (ExternalCall a M vs v)"

inductive_simps sim_action_simps [simp]:
  "InitialThreadAction  obs"
  "ThreadFinishAction  obs"
  "NormalAction (NewHeapElem a hT)  obs"
  "NormalAction (ReadMem ad al v)  obs"
  "NormalAction (WriteMem ad al v)  obs"
  "NormalAction (ThreadStart t)  obs"
  "NormalAction (ThreadJoin t)  obs"
  "NormalAction (SyncLock a)  obs"
  "NormalAction (SyncUnlock a)  obs"
  "NormalAction (ObsInterrupt t)  obs"
  "NormalAction (ObsInterrupted t)  obs"
  "NormalAction (ExternalCall a M vs v)  obs"

  "obs  InitialThreadAction"
  "obs  ThreadFinishAction"
  "obs  NormalAction (NewHeapElem a hT)"
  "obs  NormalAction (ReadMem ad al v')"
  "obs  NormalAction (WriteMem ad al v')"
  "obs  NormalAction (ThreadStart t)"
  "obs  NormalAction (ThreadJoin t)"
  "obs  NormalAction (SyncLock a)"
  "obs  NormalAction (SyncUnlock a)"
  "obs  NormalAction (ObsInterrupt t)"
  "obs  NormalAction (ObsInterrupted t)"
  "obs  NormalAction (ExternalCall a M vs v)"

lemma sim_action_trans [trans]:
  " obs  obs'; obs'  obs''   obs  obs''"
by(erule sim_action.cases) auto

lemma sim_action_sym [sym]:
  assumes "obs  obs'"
  shows "obs'  obs"
using assms by cases simp_all

lemma sim_actions_sym [sym]:
  "E [≈] E'  E' [≈] E"
unfolding sim_actions_def
by(auto simp add: llist_all2_conv_all_lnth split_beta intro: sim_action_sym)

lemma sim_actions_action_obsD:
  "E [≈] E'  action_obs E a  action_obs E' a"
unfolding sim_actions_def action_obs_def
by(cases "enat a < llength E")(auto dest: llist_all2_lnthD llist_all2_llengthD simp add: split_beta lnth_beyond split: enat.split)

lemma sim_actions_action_tidD:
  "E [≈] E'  action_tid E a = action_tid E' a"
unfolding sim_actions_def action_tid_def
by(cases "enat a < llength E")(auto dest: llist_all2_lnthD llist_all2_llengthD simp add: lnth_beyond split: enat.split)

lemma action_loc_aux_sim_action:
  "a  a'  action_loc_aux P a = action_loc_aux P a'"
by(auto elim!: action_loc_aux_cases intro: action_loc_aux_intros)

lemma eq_into_sim_actions: 
  assumes "E = E'"
  shows "E [≈] E'"
unfolding sim_actions_def assms
by(rule llist_all2_reflI)(auto)

subsection ‹Well-formedness conditions for execution sets›

locale executions_base =
  fixes  :: "('addr, 'thread_id) execution set"
  and P :: "'m prog"

locale drf =
  executions_base  P
  for  :: "('addr, 'thread_id) execution set"
  and P :: "'m prog" +
  assumes ℰ_new_actions_for_fun:
  " E  ; a  new_actions_for P E adal; a'  new_actions_for P E adal   a = a'"
  and ℰ_sequential_completion:
  " E  ; P  (E, ws) ; a.  a < r; a  read_actions E   P,E  a ↝mrw ws a 
   E'  . ws'. P  (E', ws')   ltake (enat r) E = ltake (enat r) E'  sequentially_consistent P (E', ws') 
                 action_tid E r = action_tid E' r  action_obs E r  action_obs E' r 
                 (r  actions E  r  actions E')"

locale executions_aux =
  executions_base  P
  for  :: "('addr, 'thread_id) execution set"
  and P :: "'m prog" +
  assumes init_before_read:
  "  E  ; P  (E, ws) ; r  read_actions E; adal  action_loc P E r; 
      a.  a < r; a  read_actions E   P,E  a ↝mrw ws a 
   i<r. i  new_actions_for P E adal"
  and ℰ_new_actions_for_fun:
  " E  ; a  new_actions_for P E adal; a'  new_actions_for P E adal   a = a'"

locale sc_legal =
  executions_aux  P
  for  :: "('addr, 'thread_id) execution set"
  and P :: "'m prog" +
  assumes ℰ_hb_completion:
  " E  ; P  (E, ws) ; a.  a < r; a  read_actions E   P,E  a ↝mrw ws a 
   E'  . ws'. P  (E', ws')   ltake (enat r) E = ltake (enat r) E' 
                 (a  read_actions E'. if a < r then ws' a = ws a else P,E'  ws' a ≤hb a) 
                 action_tid E' r = action_tid E r  
                 (if r  read_actions E then sim_action else (=)) (action_obs E' r) (action_obs E r) 
                 (r  actions E  r  actions E')"

locale jmm_consistent =
  drf?: drf  P +
  sc_legal  P
  for  :: "('addr, 'thread_id) execution set"
  and P :: "'m prog"

subsection ‹Legal executions›

record ('addr, 'thread_id) pre_justifying_execution =
  committed :: "JMM_action set"
  justifying_exec :: "('addr, 'thread_id) execution"
  justifying_ws :: "write_seen"

record ('addr, 'thread_id) justifying_execution = 
  "('addr, 'thread_id) pre_justifying_execution" +
  action_translation :: "JMM_action  JMM_action"

type_synonym ('addr, 'thread_id) justification = "nat  ('addr, 'thread_id) justifying_execution"

definition wf_action_translation_on :: 
  "('addr, 'thread_id) execution  ('addr, 'thread_id) execution  JMM_action set  (JMM_action  JMM_action)  bool"
where
  "wf_action_translation_on E E' A f 
   inj_on f (actions E)  
   (a  A. action_tid E a = action_tid E' (f a)  action_obs E a  action_obs E' (f a))"

abbreviation wf_action_translation :: "('addr, 'thread_id) execution  ('addr, 'thread_id) justifying_execution  bool"
where
  "wf_action_translation E J  
   wf_action_translation_on (justifying_exec J) E (committed J) (action_translation J)"

context
  fixes P :: "'m prog"
  and E :: "('addr, 'thread_id) execution"
  and ws :: "write_seen"
  and J :: "('addr, 'thread_id) justification"
begin

text ‹
  This context defines the causality constraints for the JMM.
  The weak versions are for the fixed JMM as presented by Sevcik and Aspinall at ECOOP 2008.
›

text ‹Committed actions are an ascending chain with all actions of E as a limit›
definition is_commit_sequence :: bool where 
  "is_commit_sequence  
   committed (J 0) = {} 
   (n. action_translation (J n) ` committed (J n)  action_translation (J (Suc n)) ` committed (J (Suc n))) 
   actions E = (n. action_translation (J n) ` committed (J n))"

definition justification_well_formed :: bool where
  "justification_well_formed  (n. P  (justifying_exec (J n), justifying_ws (J n)) )"

definition committed_subset_actions :: bool where ― ‹JMM constraint 1›
  "committed_subset_actions  (n. committed (J n)  actions (justifying_exec (J n)))"

definition happens_before_committed :: bool where ― ‹JMM constraint 2›
  "happens_before_committed  
  (n. happens_before P (justifying_exec (J n)) |` committed (J n) =
       inv_imageP (happens_before P E) (action_translation (J n)) |` committed (J n))"

definition happens_before_committed_weak :: bool where ― ‹relaxed JMM constraint›
  "happens_before_committed_weak 
  (n. r  read_actions (justifying_exec (J n))  committed (J n).
       let r' = action_translation (J n) r;
           w' = ws r';
           w = inv_into (actions (justifying_exec (J n))) (action_translation (J n)) w' in
         (P,E  w' ≤hb r'  P,justifying_exec (J n)  w ≤hb r) 
         ¬ P,justifying_exec (J n)  r ≤hb w)"

definition sync_order_committed :: bool where ― ‹JMM constraint 3›
  "sync_order_committed 
  (n. sync_order P (justifying_exec (J n)) |` committed (J n) =
       inv_imageP (sync_order P E) (action_translation (J n)) |` committed (J n))"

definition value_written_committed :: bool where ― ‹JMM constraint 4›
  "value_written_committed 
  (n. w  write_actions (justifying_exec (J n))  committed (J n). 
       let w' = action_translation (J n) w
       in (adal  action_loc P E w'. value_written P (justifying_exec (J n)) w adal = value_written P E w' adal))"

definition write_seen_committed :: bool where ― ‹JMM constraint 5›
  "write_seen_committed 
  (n. r'  read_actions (justifying_exec (J n))  committed (J n).
       let r = action_translation (J n) r';
           r'' = inv_into (actions (justifying_exec (J (Suc n)))) (action_translation (J (Suc n))) r
       in action_translation (J (Suc n)) (justifying_ws (J (Suc n)) r'') = ws r)"

text ‹uncommited reads see writes that happen before them -- JMM constraint 6›
(* this constraint does not apply to the 0th justifying execution, so reads may see arbitrary writes,
   but this cannot be exploited because reads cannot be committed in the 1st justifying execution
   since no writes are committed in the 0th execution *)
definition uncommitted_reads_see_hb :: bool where
  "uncommitted_reads_see_hb 
  (n. r'  read_actions (justifying_exec (J (Suc n))).
       action_translation (J (Suc n)) r'  action_translation (J n) ` committed (J n)  
       P,justifying_exec (J (Suc n))  justifying_ws (J (Suc n)) r' ≤hb r')"

text ‹
  newly committed reads see already committed writes and write-seen
  relationship must not change any more  -- JMM constraint 7
›
definition committed_reads_see_committed_writes :: bool where
  "committed_reads_see_committed_writes 
  (n. r'  read_actions (justifying_exec (J (Suc n)))  committed (J (Suc n)).
       let r = action_translation (J (Suc n)) r';
           committed_n = action_translation (J n) ` committed (J n)
       in r  committed_n 
          (action_translation (J (Suc n)) (justifying_ws (J (Suc n)) r')  committed_n  ws r  committed_n))"
definition committed_reads_see_committed_writes_weak :: bool where
  "committed_reads_see_committed_writes_weak 
  (n. r'  read_actions (justifying_exec (J (Suc n)))  committed (J (Suc n)).
       let r = action_translation (J (Suc n)) r';
           committed_n = action_translation (J n) ` committed (J n)
       in r  committed_n  ws r  committed_n)"

text ‹external actions must be committed as soon as hb-subsequent actions are committed  -- JMM constraint 9›
definition external_actions_committed :: bool where
  "external_actions_committed 
  (n. a  external_actions (justifying_exec (J n)). a'  committed (J n).
       P,justifying_exec (J n)  a ≤hb a'  a  committed (J n))"

text ‹well-formedness conditions for action translations›
definition wf_action_translations :: bool where
  "wf_action_translations 
  (n. wf_action_translation_on (justifying_exec (J n)) E (committed (J n)) (action_translation (J n)))"

end

text ‹
  Rule 8 of the justification for the JMM is incorrect because there might be no
  transitive reduction of the happens-before relation for an infinite execution, if
  infinitely many initialisation actions have to be ordered before the start
  action of every thread.
  Hence, is_justified_by› omits this constraint.
›

primrec is_justified_by ::
  "'m prog  ('addr, 'thread_id) execution × write_seen  ('addr, 'thread_id) justification  bool" 
  ("_  _ justified'_by _" [51, 50, 50] 50)
where
  "P  (E, ws) justified_by J 
   is_commit_sequence E J 
   justification_well_formed P J 
   committed_subset_actions J 
   happens_before_committed P E J 
   sync_order_committed P E J 
   value_written_committed P E J 
   write_seen_committed ws J  
   uncommitted_reads_see_hb P J 
   committed_reads_see_committed_writes ws J  
   external_actions_committed P J  
   wf_action_translations E J"

text ‹
  Sevcik requires in the fixed JMM that external actions may
  only be committed when everything that happens before has 
  already been committed. On the level of legality, this constraint
  is vacuous because it is always possible to delay committing
  external actions, so we omit it here.
›
primrec is_weakly_justified_by ::
  "'m prog  ('addr, 'thread_id) execution × write_seen  ('addr, 'thread_id) justification  bool" 
  ("_  _ weakly'_justified'_by _" [51, 50, 50] 50)
where
  "P  (E, ws) weakly_justified_by J 
   is_commit_sequence E J 
   justification_well_formed P J 
   committed_subset_actions J 
   happens_before_committed_weak P E ws J 
   ― ‹no sync_order› constraint›
   value_written_committed P E J 
   write_seen_committed ws J  
   uncommitted_reads_see_hb P J 
   committed_reads_see_committed_writes_weak ws J  
   wf_action_translations E J"

text ‹
  Notion of conflict is strengthened to explicitly exclude volatile locations.
  Otherwise, the following program is not correctly synchronised:

\begin{verbatim}
  volatile x = 0;
  ---------------
  r = x; | x = 1;
\end{verbatim}

  because in the SC execution [Init x 0, (t1, Read x 0), (t2, Write x 1)],
  the read and write are unrelated in hb, because synchronises-with is 
  asymmetric for volatiles.

  The JLS considers conflicting volatiles for data races, but this is only a 
  remark on the DRF guarantee. See JMM mailing list posts \#2477 to 2488.
›
(* Problem already exists in Sevcik's formalisation *)

definition non_volatile_conflict ::
  "'m prog  ('addr, 'thread_id) execution  JMM_action  JMM_action  bool" 
  ("_,_ /(_)(_)" [51,50,50,50] 51)
where 
  "P,E  a  a' 
   (a  read_actions E  a'  write_actions E 
    a  write_actions E  a'  read_actions E 
    a  write_actions E  a'  write_actions E) 
   (ad al. (ad, al)  action_loc P E a  action_loc P E a'  ¬ is_volatile P al)"

definition correctly_synchronized :: "'m prog  ('addr, 'thread_id) execution set  bool"
where
  "correctly_synchronized P  
  (E  . ws. P  (E, ws)   sequentially_consistent P (E, ws) 
     (a  actions E. a'  actions E. P,E  a  a' 
           P,E  a ≤hb a'  P,E  a' ≤hb a))"

primrec gen_legal_execution ::
  "('m prog  ('addr, 'thread_id) execution × write_seen  ('addr, 'thread_id) justification  bool)
   'm prog  ('addr, 'thread_id) execution set  ('addr, 'thread_id) execution × write_seen  bool"
where
  "gen_legal_execution is_justification P  (E, ws) 
   E    P  (E, ws)   
   (J. is_justification P (E, ws) J  range (justifying_exec  J)  )"

abbreviation legal_execution :: 
  "'m prog  ('addr, 'thread_id) execution set  ('addr, 'thread_id) execution × write_seen  bool"
where
  "legal_execution  gen_legal_execution is_justified_by"

abbreviation weakly_legal_execution :: 
  "'m prog  ('addr, 'thread_id) execution set  ('addr, 'thread_id) execution × write_seen  bool"
where
  "weakly_legal_execution  gen_legal_execution is_weakly_justified_by"

declare gen_legal_execution.simps [simp del]

lemma sym_non_volatile_conflict:
  "symP (non_volatile_conflict P E)"
unfolding non_volatile_conflict_def
by(rule symPI) blast

lemma legal_executionI:
  " E  ; P  (E, ws) ; is_justification P (E, ws) J; range (justifying_exec  J)   
   gen_legal_execution is_justification P  (E, ws)"
unfolding gen_legal_execution.simps by blast

lemma legal_executionE:
  assumes "gen_legal_execution is_justification P  (E, ws)"
  obtains J where "E  " "P  (E, ws) " "is_justification P (E, ws) J" "range (justifying_exec  J)  "
using assms unfolding gen_legal_execution.simps by blast

lemma legal_ℰD: "gen_legal_execution is_justification P  (E, ws)  E  "
by(erule legal_executionE)

lemma legal_wf_execD:
  "gen_legal_execution is_justification P  Ews  P  Ews "
by(cases Ews)(auto elim: legal_executionE)

lemma correctly_synchronizedD:
  " correctly_synchronized P ; E  ; P  (E, ws) ; sequentially_consistent P (E, ws) 
   a a'. a  actions E  a'  actions E  P,E  a  a'  P,E  a ≤hb a'  P,E  a' ≤hb a"
unfolding correctly_synchronized_def by blast

lemma wf_action_translation_on_actionD:
  " wf_action_translation_on E E' A f; a  A  
   action_tid E a = action_tid E' (f a)  action_obs E a  action_obs E' (f a)"
unfolding wf_action_translation_on_def by blast

lemma wf_action_translation_on_inj_onD:
  "wf_action_translation_on E E' A f  inj_on f (actions E)"
unfolding wf_action_translation_on_def by simp

lemma wf_action_translation_on_action_locD:
  " wf_action_translation_on E E' A f; a  A 
   action_loc P E a = action_loc P E' (f a)"
apply(drule (1) wf_action_translation_on_actionD)
apply(cases "(P, action_obs E a)" rule: action_loc_aux.cases)
apply auto
done

lemma weakly_justified_write_seen_hb_read_committed:
  assumes J: "P  (E, ws) weakly_justified_by J"
  and r: "r  read_actions (justifying_exec (J n))" "r  committed (J n)"
  shows "ws (action_translation (J n) r)  action_translation (J n) ` committed (J n)"
using r
proof(induct n arbitrary: r)
  case 0
  from J have [simp]: "committed (J 0) = {}"
    by(simp add: is_commit_sequence_def)
  with 0 show ?case by simp
next
  case (Suc n)
  let ?E = "λn. justifying_exec (J n)"
    and ?ws = "λn. justifying_ws (J n)"
    and ?C = "λn. committed (J n)"
    and  = "λn. action_translation (J n)"
    
  note r = r  read_actions (?E (Suc n))
  hence "r  actions (?E (Suc n))" by simp
  
  from J have wfan: "wf_action_translation_on (?E n) E (?C n) ( n)"
    and wfaSn: "wf_action_translation_on (?E (Suc n)) E (?C (Suc n)) ( (Suc n))"
    by(simp_all add: wf_action_translations_def)
  
  from wfaSn have injSn: "inj_on ( (Suc n)) (actions (?E (Suc n)))"
    by(rule wf_action_translation_on_inj_onD)
  from J have C_sub_A: "?C (Suc n)  actions (?E (Suc n))"
    by(simp add: committed_subset_actions_def)
  from J have CnCSn: " n ` ?C n   (Suc n) ` ?C (Suc n)"
    by(simp add: is_commit_sequence_def)
    
  from J have wsSn: "is_write_seen P (?E (Suc n)) (?ws (Suc n))"
    by(simp add: justification_well_formed_def)
  from r obtain ad al v where "action_obs (?E (Suc n)) r = NormalAction (ReadMem ad al v)" by cases
  from is_write_seenD[OF wsSn r this]
  have wsSn: "?ws (Suc n) r  actions (?E (Suc n))" by simp

  show ?case
  proof(cases " (Suc n) r   n ` ?C n")
    case True
    then obtain r' where r': "r'  ?C n"
      and r_r': " (Suc n) r =  n r'" by(auto)
    from r' wfan have "action_tid (?E n) r' = action_tid E ( n r')"
      and "action_obs (?E n) r'  action_obs E ( n r')"
      by(blast dest: wf_action_translation_on_actionD)+
    moreover from r' CnCSn have " (Suc n) r   (Suc n) ` ?C (Suc n)" 
      unfolding r_r' by auto
    hence "r  ?C (Suc n)"
      unfolding inj_on_image_mem_iff[OF injSn C_sub_A r  actions (?E (Suc n))] .
    with wfaSn have "action_tid (?E (Suc n)) r = action_tid E ( (Suc n) r)"
      and "action_obs (?E (Suc n)) r  action_obs E ( (Suc n) r)"
      by(blast dest: wf_action_translation_on_actionD)+
    ultimately have tid: "action_tid (?E n) r' = action_tid (?E (Suc n)) r"
      and obs: "action_obs (?E n) r'  action_obs (?E (Suc n)) r"
      unfolding r_r' by(auto intro: sim_action_trans sim_action_sym)
    
    from J have "?C n  actions (?E n)" by(simp add: committed_subset_actions_def)
    with r' have "r'  actions (?E n)" by blast
    with r obs have "r'  read_actions (?E n)"
      by cases(auto intro: read_actions.intros)
    hence ws: "ws ( n r')   n ` ?C n" using r' by(rule Suc)

    have r_conv_inv: "r = inv_into (actions (?E (Suc n))) ( (Suc n)) ( n r')"
      using r  actions (?E (Suc n)) unfolding r_r'[symmetric]
      by(simp add: inv_into_f_f[OF injSn])
    with r'  ?C n r J r'  read_actions (?E n)
    have ws_eq: " (Suc n) (?ws (Suc n) r) = ws ( n r')"
      by(simp add: Let_def write_seen_committed_def)
    with ws CnCSn have " (Suc n) (?ws (Suc n) r)   (Suc n) ` ?C (Suc n)" by auto
    hence "?ws (Suc n) r  ?C (Suc n)"
      by(subst (asm) inj_on_image_mem_iff[OF injSn C_sub_A wsSn])
    moreover from ws CnCSn have "ws ( (Suc n) r)   (Suc n) ` ?C (Suc n)"
      unfolding r_r' by auto
    ultimately show ?thesis by simp
  next
    case False
    with r r  ?C (Suc n) J
    have "ws ( (Suc n) r)   n ` ?C n"
      unfolding is_weakly_justified_by.simps Let_def committed_reads_see_committed_writes_weak_def
      by blast
    hence "ws ( (Suc n) r)   (Suc n) ` ?C (Suc n)"
      using CnCSn by blast+
    thus ?thesis by(simp add: inj_on_image_mem_iff[OF injSn C_sub_A wsSn])
  qed
qed

lemma justified_write_seen_hb_read_committed:
  assumes J: "P  (E, ws) justified_by J"
  and r: "r  read_actions (justifying_exec (J n))" "r  committed (J n)"
  shows "justifying_ws (J n) r  committed (J n)" (is ?thesis1)
  and "ws (action_translation (J n) r)  action_translation (J n) ` committed (J n)" (is ?thesis2)
proof -
  have "?thesis1  ?thesis2" using r
  proof(induct n arbitrary: r)
    case 0
    from J have [simp]: "committed (J 0) = {}"
      by(simp add: is_commit_sequence_def)
    with 0 show ?case by simp
  next
    case (Suc n)
    let ?E = "λn. justifying_exec (J n)"
      and ?ws = "λn. justifying_ws (J n)"
      and ?C = "λn. committed (J n)"
      and  = "λn. action_translation (J n)"
    
    note r = r  read_actions (?E (Suc n))
    hence "r  actions (?E (Suc n))" by simp
    
    from J have wfan: "wf_action_translation_on (?E n) E (?C n) ( n)"
      and wfaSn: "wf_action_translation_on (?E (Suc n)) E (?C (Suc n)) ( (Suc n))"
      by(simp_all add: wf_action_translations_def)
    
    from wfaSn have injSn: "inj_on ( (Suc n)) (actions (?E (Suc n)))"
      by(rule wf_action_translation_on_inj_onD)
    from J have C_sub_A: "?C (Suc n)  actions (?E (Suc n))"
      by(simp add: committed_subset_actions_def)
    from J have CnCSn: " n ` ?C n   (Suc n) ` ?C (Suc n)"
      by(simp add: is_commit_sequence_def)
    
    from J have wsSn: "is_write_seen P (?E (Suc n)) (?ws (Suc n))"
      by(simp add: justification_well_formed_def)
    from r obtain ad al v where "action_obs (?E (Suc n)) r = NormalAction (ReadMem ad al v)" by cases
    from is_write_seenD[OF wsSn r this]
    have wsSn: "?ws (Suc n) r  actions (?E (Suc n))" by simp

    show ?case
    proof(cases " (Suc n) r   n ` ?C n")
      case True
      then obtain r' where r': "r'  ?C n"
        and r_r': " (Suc n) r =  n r'" by(auto)
      from r' wfan have "action_tid (?E n) r' = action_tid E ( n r')"
        and "action_obs (?E n) r'  action_obs E ( n r')"
        by(blast dest: wf_action_translation_on_actionD)+
      moreover from r' CnCSn have " (Suc n) r   (Suc n) ` ?C (Suc n)" 
        unfolding r_r' by auto
      hence "r  ?C (Suc n)"
        unfolding inj_on_image_mem_iff[OF injSn C_sub_A r  actions (?E (Suc n))] .
      with wfaSn have "action_tid (?E (Suc n)) r = action_tid E ( (Suc n) r)"
        and "action_obs (?E (Suc n)) r  action_obs E ( (Suc n) r)"
        by(blast dest: wf_action_translation_on_actionD)+
      ultimately have tid: "action_tid (?E n) r' = action_tid (?E (Suc n)) r"
        and obs: "action_obs (?E n) r'  action_obs (?E (Suc n)) r"
        unfolding r_r' by(auto intro: sim_action_trans sim_action_sym)
      
      from J have "?C n  actions (?E n)" by(simp add: committed_subset_actions_def)
      with r' have "r'  actions (?E n)" by blast
      with r obs have "r'  read_actions (?E n)"
        by cases(auto intro: read_actions.intros)
      hence "?ws n r'  ?C n  ws ( n r')   n ` ?C n" using r' by(rule Suc)
      then obtain ws: "ws ( n r')   n ` ?C n" ..

      have r_conv_inv: "r = inv_into (actions (?E (Suc n))) ( (Suc n)) ( n r')"
        using r  actions (?E (Suc n)) unfolding r_r'[symmetric]
        by(simp add: inv_into_f_f[OF injSn])
      with r'  ?C n r J r'  read_actions (?E n)
      have ws_eq: " (Suc n) (?ws (Suc n) r) = ws ( n r')"
        by(simp add: Let_def write_seen_committed_def)
      with ws CnCSn have " (Suc n) (?ws (Suc n) r)   (Suc n) ` ?C (Suc n)" by auto
      hence "?ws (Suc n) r  ?C (Suc n)"
        by(subst (asm) inj_on_image_mem_iff[OF injSn C_sub_A wsSn])
      moreover from ws CnCSn have "ws ( (Suc n) r)   (Suc n) ` ?C (Suc n)"
        unfolding r_r' by auto
      ultimately show ?thesis by simp
    next
      case False
      with r r  ?C (Suc n) J
      have " (Suc n) (?ws (Suc n) r)   n ` ?C n" 
        and "ws ( (Suc n) r)   n ` ?C n"
        unfolding is_justified_by.simps Let_def committed_reads_see_committed_writes_def
        by blast+
      hence " (Suc n) (?ws (Suc n) r)   (Suc n) ` ?C (Suc n)"
        and "ws ( (Suc n) r)   (Suc n) ` ?C (Suc n)"
        using CnCSn by blast+
      thus ?thesis by(simp add: inj_on_image_mem_iff[OF injSn C_sub_A wsSn])
    qed
  qed
  thus ?thesis1 ?thesis2 by simp_all
qed

lemma is_justified_by_imp_is_weakly_justified_by:
  assumes justified: "P  (E, ws) justified_by J"
  and wf: "P  (E, ws) "
  shows "P  (E, ws) weakly_justified_by J"
  unfolding is_weakly_justified_by.simps
proof(intro conjI)
  let ?E = "λn. justifying_exec (J n)"
    and ?ws = "λn. justifying_ws (J n)"
    and ?C = "λn. committed (J n)"
    and  = "λn. action_translation (J n)"

  from justified
  show "is_commit_sequence E J" "justification_well_formed P J" "committed_subset_actions J"
    "value_written_committed P E J" "write_seen_committed ws J" "uncommitted_reads_see_hb P J"
    "wf_action_translations E J" by(simp_all)
  
  show "happens_before_committed_weak P E ws J"
    unfolding happens_before_committed_weak_def Let_def
  proof(intro strip conjI)
    fix n r
    assume "r  read_actions (?E n)  ?C n"
    hence read: "r  read_actions (?E n)" and committed: "r  ?C n" by simp_all
    with justified have committed_ws: "?ws n r  ?C n"
      and committed_ws': "ws ( n r)   n ` ?C n"
      by(rule justified_write_seen_hb_read_committed)+
    from committed_ws' obtain w where w: "ws ( n r) =  n w"
      and committed_w: "w  ?C n" by blast

    from committed_w justified have "w  actions (?E n)" by(auto simp add: committed_subset_actions_def)
    moreover from justified have "inj_on ( n) (actions (?E n))"
      by(auto simp add: wf_action_translations_def dest: wf_action_translation_on_inj_onD)
    ultimately have w_def: "w = inv_into (actions (?E n)) ( n) (ws ( n r))"
      by(simp_all add: w)

    from committed committed_w
    have "P,?E n  w ≤hb r  (happens_before P (?E n) |` ?C n) w r" by auto
    also have "  (inv_imageP (happens_before P E) ( n) |` ?C n) w r"
      using justified by(simp add: happens_before_committed_def)
    also have "  P,E   n w ≤hb  n r" using committed committed_w by auto
    finally show "P,E  ws ( n r) ≤hb  n r  P,?E n  inv_into (actions (?E n)) ( n) (ws ( n r)) ≤hb r"
      unfolding w[symmetric] unfolding w_def ..

    have "P,?E n r ≤hb w  (happens_before P (?E n) |` ?C n) r w" 
      using committed committed_w by auto
    also have "  (inv_imageP (happens_before P E) ( n) |` ?C n) r w"
      using justified by(simp add: happens_before_committed_def)
    also have "  P,E   n r ≤hb ws ( n r)" using w committed committed_w by auto
    also {
      from read obtain ad al v where "action_obs (?E n) r = NormalAction (ReadMem ad al v)" by cases auto
      with justified committed obtain v' where obs': "action_obs E ( n r) = NormalAction (ReadMem ad al v')"
        by(fastforce simp add: wf_action_translations_def dest!: wf_action_translation_on_actionD)
      moreover from committed justified have " n r  actions E"
        by(auto simp add: is_commit_sequence_def)
      ultimately have read': " n r  read_actions E" by(auto intro: read_actions.intros)
      from wf have "is_write_seen P E ws" by(rule wf_exec_is_write_seenD)
      from is_write_seenD[OF this read' obs']
      have "¬ P,E   n r ≤hb ws ( n r)" by simp }
    ultimately show "¬ P,?E n  r ≤hb inv_into (actions (?E n)) ( n) (ws ( n r))"
      unfolding w_def by simp
  qed

  from justified have "committed_reads_see_committed_writes ws J" by simp
  thus "committed_reads_see_committed_writes_weak ws J"
    by(auto simp add: committed_reads_see_committed_writes_def committed_reads_see_committed_writes_weak_def)
qed

corollary legal_imp_weakly_legal_execution:
  "legal_execution P  Ews  weakly_legal_execution P  Ews"
by(cases Ews)(auto 4 4 simp add: gen_legal_execution.simps simp del: is_justified_by.simps is_weakly_justified_by.simps intro: is_justified_by_imp_is_weakly_justified_by)

lemma drop_0th_justifying_exec:
  assumes "P  (E, ws) justified_by J"
  and wf: "P  (E', ws') "
  shows "P  (E, ws) justified_by (J(0 := committed = {}, justifying_exec = E', justifying_ws = ws', action_translation = id))"
  (is "_  _ justified_by ?J")
using assms
unfolding is_justified_by.simps is_commit_sequence_def
  justification_well_formed_def committed_subset_actions_def happens_before_committed_def
  sync_order_committed_def value_written_committed_def write_seen_committed_def uncommitted_reads_see_hb_def
  committed_reads_see_committed_writes_def external_actions_committed_def wf_action_translations_def
proof(intro conjI strip)
  let ?E = "λn. justifying_exec (?J n)"
    and  = "λn. action_translation (?J n)"
    and ?C = "λn. committed (?J n)"
    and ?ws = "λn. justifying_ws (?J n)"

  show "?C 0 = {}" by simp

  from assms have C_0: "committed (J 0) = {}" by(simp add: is_commit_sequence_def)
  hence "(n.  n ` ?C n) = (n. action_translation (J n) ` committed (J n))"
    by -(rule SUP_cong, simp_all)
  also have " = actions E" using assms by(simp add: is_commit_sequence_def)
  finally show "actions E = (n.  n ` ?C n)" .. 

  fix n
  { fix r'
    assume "r'  read_actions (?E (Suc n))"
    thus " (Suc n) r'   n ` ?C n  P,?E (Suc n)  ?ws (Suc n) r' ≤hb r'"
      using assms by(auto dest!: bspec simp add: uncommitted_reads_see_hb_def is_commit_sequence_def) }
  { fix r'
    assume r': "r'  read_actions (?E (Suc n))  ?C (Suc n)"

    have "n  0"
    proof
      assume "n = 0"
      hence "r'  read_actions (justifying_exec (J 1))  committed (J 1)" using r' by simp
      hence "action_translation (J 1) r'  action_translation (J 0) ` committed (J 0)  
             ws (action_translation (J 1) r')  action_translation (J 0) ` committed (J 0)" using assms
        unfolding One_nat_def is_justified_by.simps Let_def committed_reads_see_committed_writes_def
        by(metis (lifting))
      thus False unfolding C_0 by simp
    qed
    thus "let r =  (Suc n) r'; committed_n =  n ` ?C n
       in r  committed_n 
          ( (Suc n) (?ws (Suc n) r')  committed_n  ws r  committed_n)"
      using assms r' by(simp add: committed_reads_see_committed_writes_def) }
  { fix a a'
    assume "a  external_actions (?E n)" 
      and "a'  ?C n" "P,?E n  a ≤hb a'"
    moreover hence "n > 0" by(simp split: if_split_asm)
    ultimately show "a  ?C n" using assms
      by(simp add: external_actions_committed_def) blast }
    
  from assms have "wf_action_translation E (?J 0)"
    by(simp add: wf_action_translations_def wf_action_translation_on_def)
  thus "wf_action_translation E (?J n)" using assms by(simp add: wf_action_translations_def)
qed auto

lemma drop_0th_weakly_justifying_exec:
  assumes "P  (E, ws) weakly_justified_by J"
  and wf: "P  (E', ws') "
  shows "P  (E, ws) weakly_justified_by (J(0 := committed = {}, justifying_exec = E', justifying_ws = ws', action_translation = id))"
  (is "_  _ weakly_justified_by ?J")
using assms
unfolding is_weakly_justified_by.simps is_commit_sequence_def
  justification_well_formed_def committed_subset_actions_def happens_before_committed_weak_def
  value_written_committed_def write_seen_committed_def uncommitted_reads_see_hb_def
  committed_reads_see_committed_writes_weak_def external_actions_committed_def wf_action_translations_def
proof(intro conjI strip)
  let ?E = "λn. justifying_exec (?J n)"
    and  = "λn. action_translation (?J n)"
    and ?C = "λn. committed (?J n)"
    and ?ws = "λn. justifying_ws (?J n)"

  show "?C 0 = {}" by simp

  from assms have C_0: "committed (J 0) = {}" by(simp add: is_commit_sequence_def)
  hence "(n.  n ` ?C n) = (n. action_translation (J n) ` committed (J n))"
    by -(rule SUP_cong, simp_all)
  also have " = actions E" using assms by(simp add: is_commit_sequence_def)
  finally show "actions E = (n.  n ` ?C n)" .. 

  fix n
  { fix r'
    assume "r'  read_actions (?E (Suc n))"
    thus " (Suc n) r'   n ` ?C n  P,?E (Suc n)  ?ws (Suc n) r' ≤hb r'"
      using assms by(auto dest!: bspec simp add: uncommitted_reads_see_hb_def is_commit_sequence_def) }
  { fix r'
    assume r': "r'  read_actions (?E (Suc n))  ?C (Suc n)"

    have "n  0"
    proof
      assume "n = 0"
      hence "r'  read_actions (justifying_exec (J 1))  committed (J 1)" using r' by simp
      hence "action_translation (J 1) r'  action_translation (J 0) ` committed (J 0)  
             ws (action_translation (J 1) r')  action_translation (J 0) ` committed (J 0)" using assms
        unfolding One_nat_def is_weakly_justified_by.simps Let_def committed_reads_see_committed_writes_weak_def
        by(metis (lifting))
      thus False unfolding C_0 by simp
    qed
    thus "let r =  (Suc n) r'; committed_n =  n ` ?C n
       in r  committed_n  ws r  committed_n"
      using assms r' by(simp add: committed_reads_see_committed_writes_weak_def) }
    
  from assms have "wf_action_translation E (?J 0)"
    by(simp add: wf_action_translations_def wf_action_translation_on_def)
  thus "wf_action_translation E (?J n)" using assms by(simp add: wf_action_translations_def)
qed auto

subsection ‹Executions with common prefix›

lemma actions_change_prefix:
  assumes read: "a  actions E"
  and prefix: "ltake n E [≈] ltake n E'"
  and rn: "enat a < n"
  shows "a  actions E'"
using llist_all2_llengthD[OF prefix[unfolded sim_actions_def]] read rn
by(simp add: actions_def min_def split: if_split_asm)

lemma action_obs_change_prefix:
  assumes prefix: "ltake n E [≈] ltake n E'"
  and rn: "enat a < n"
  shows "action_obs E a  action_obs E' a"
proof -
  from rn have "action_obs E a = action_obs (ltake n E) a"
    by(simp add: action_obs_def lnth_ltake)
  also from prefix have "  action_obs (ltake n E') a"
    by(rule sim_actions_action_obsD)
  also have " = action_obs E' a" using rn
    by(simp add: action_obs_def lnth_ltake)
  finally show ?thesis .
qed

lemma action_obs_change_prefix_eq:
  assumes prefix: "ltake n E = ltake n E'"
  and rn: "enat a < n"
  shows "action_obs E a = action_obs E' a"
proof -
  from rn have "action_obs E a = action_obs (ltake n E) a"
    by(simp add: action_obs_def lnth_ltake)
  also from prefix have " = action_obs (ltake n E') a"
    by(simp add: action_obs_def)
  also have " = action_obs E' a" using rn
    by(simp add: action_obs_def lnth_ltake)
  finally show ?thesis .
qed

lemma read_actions_change_prefix:
  assumes read: "r  read_actions E"
  and prefix: "ltake n E [≈] ltake n E'" "enat r < n"
  shows "r  read_actions E'"
using read action_obs_change_prefix[OF prefix] actions_change_prefix[OF _ prefix]
by(cases)(auto intro: read_actions.intros)

lemma sim_action_is_write_action_eq:
  assumes "obs  obs'"
  shows "is_write_action obs  is_write_action obs'"
using assms by cases simp_all

lemma write_actions_change_prefix:
  assumes "write": "w  write_actions E"
  and prefix: "ltake n E [≈] ltake n E'" "enat w < n"
  shows "w  write_actions E'"
using "write" action_obs_change_prefix[OF prefix] actions_change_prefix[OF _ prefix]
by(cases)(auto intro: write_actions.intros dest: sim_action_is_write_action_eq)

lemma action_loc_change_prefix:
  assumes "ltake n E [≈] ltake n E'" "enat a < n"
  shows "action_loc P E a = action_loc P E' a"
using action_obs_change_prefix[OF assms]
by(fastforce elim!: action_loc_aux_cases intro: action_loc_aux_intros)

lemma sim_action_is_new_action_eq:
  assumes "obs  obs'"
  shows "is_new_action obs = is_new_action obs'"
using assms by cases auto

lemma action_order_change_prefix:
  assumes ao: "E  a ≤a a'"
  and prefix: "ltake n E [≈] ltake n E'" 
  and an: "enat a < n"
  and a'n: "enat a' < n"
  shows "E'  a ≤a a'"
using ao actions_change_prefix[OF _ prefix an] actions_change_prefix[OF _ prefix a'n] action_obs_change_prefix[OF prefix an] action_obs_change_prefix[OF prefix a'n]
by(auto simp add: action_order_def split: if_split_asm dest: sim_action_is_new_action_eq)


lemma value_written_change_prefix:
  assumes eq: "ltake n E = ltake n E'"
  and an: "enat a < n"
  shows "value_written P E a = value_written P E' a"
using action_obs_change_prefix_eq[OF eq an]
by(simp add: value_written_def fun_eq_iff)

lemma action_tid_change_prefix:
  assumes prefix: "ltake n E [≈] ltake n E'" 
  and an: "enat a < n"
  shows "action_tid E a = action_tid E' a"
proof -
  from an have "action_tid E a = action_tid (ltake n E) a"
    by(simp add: action_tid_def lnth_ltake)
  also from prefix have " = action_tid (ltake n E') a"
    by(rule sim_actions_action_tidD)
  also from an have " = action_tid E' a"
    by(simp add: action_tid_def lnth_ltake)
  finally show ?thesis .
qed

lemma program_order_change_prefix:
  assumes po: "E  a ≤po a'"
  and prefix: "ltake n E [≈] ltake n E'"
  and an: "enat a < n"
  and a'n: "enat a' < n"
  shows "E'  a ≤po a'"
using po action_order_change_prefix[OF _ prefix an a'n]
  action_tid_change_prefix[OF prefix an] action_tid_change_prefix[OF prefix a'n]
by(auto elim!: program_orderE intro: program_orderI)

lemma sim_action_sactionD:
  assumes "obs  obs'"
  shows "saction P obs  saction P obs'"
using assms by cases simp_all

lemma sactions_change_prefix:
  assumes sync: "a  sactions P E"
  and prefix: "ltake n E [≈] ltake n E'"
  and rn: "enat a < n"
  shows "a  sactions P E'"
using sync action_obs_change_prefix[OF prefix rn] actions_change_prefix[OF _ prefix rn]
unfolding sactions_def by(simp add: sim_action_sactionD)

lemma sync_order_change_prefix:
  assumes so: "P,E  a ≤so a'"
  and prefix: "ltake n E [≈] ltake n E'"
  and an: "enat a < n"
  and a'n: "enat a' < n"
  shows "P,E'  a ≤so a'"
using so action_order_change_prefix[OF _ prefix an a'n] sactions_change_prefix[OF _ prefix an, of P] sactions_change_prefix[OF _ prefix a'n, of P]
by(simp add: sync_order_def)

lemma sim_action_synchronizes_withD:
  assumes "obs  obs'" "obs''  obs'''"
  shows "P  (t, obs) ↝sw (t', obs'')  P  (t, obs') ↝sw (t', obs''')"
using assms
by(auto elim!: sim_action.cases synchronizes_with.cases intro: synchronizes_with.intros)

lemma sync_with_change_prefix:
  assumes sw: "P,E  a ≤sw a'"
  and prefix: "ltake n E [≈] ltake n E'"
  and an: "enat a < n"
  and a'n: "enat a' < n"
  shows "P,E'  a ≤sw a'"
using sw sync_order_change_prefix[OF _ prefix an a'n, of P] 
  action_tid_change_prefix[OF prefix an] action_tid_change_prefix[OF prefix a'n]
  action_obs_change_prefix[OF prefix an] action_obs_change_prefix[OF prefix a'n]
by(auto simp add: sync_with_def dest: sim_action_synchronizes_withD)


lemma po_sw_change_prefix:
  assumes posw: "po_sw P E a a'"
  and prefix: "ltake n E [≈] ltake n E'"
  and an: "enat a < n"
  and a'n: "enat a' < n"
  shows "po_sw P E' a a'"
using posw sync_with_change_prefix[OF _ prefix an a'n, of P] program_order_change_prefix[OF _ prefix an a'n]
by(auto simp add: po_sw_def)


lemma happens_before_new_not_new:
  assumes tsa_ok: "thread_start_actions_ok E"
  and a: "a  actions E" 
  and a': "a'  actions E"
  and new_a: "is_new_action (action_obs E a)"
  and new_a': "¬ is_new_action (action_obs E a')"
  shows "P,E  a ≤hb a'"
proof -
  from thread_start_actions_okD[OF tsa_ok a' new_a']
  obtain i where "i  a'"
    and obs_i: "action_obs E i = InitialThreadAction" 
    and "action_tid E i = action_tid E a'" by auto
  from i  a' a' have "i  actions E"
    by(auto simp add: actions_def le_less_trans[where y="enat a'"])
  with i  a' obs_i a' new_a' have "E  i ≤a a'" by(simp add: action_order_def)
  hence "E  i ≤po a'" using ‹action_tid E i = action_tid E a'
    by(rule program_orderI)
  
  moreover {
    from i  actions E obs_i
    have "i  sactions P E" by(auto intro: sactionsI)
    from a i  actions E new_a obs_i have "E  a ≤a i" by(simp add: action_order_def)
    moreover from a new_a have "a  sactions P E" by(auto intro: sactionsI)
    ultimately have "P,E  a ≤so i" using i  sactions P E by(rule sync_orderI)
    moreover from new_a obs_i have "P  (action_tid E a, action_obs E a) ↝sw (action_tid E i, action_obs E i)"
      by cases(auto intro: synchronizes_with.intros)
    ultimately have "P,E  a ≤sw i" by(rule sync_withI) }
  ultimately show ?thesis unfolding po_sw_def [abs_def] by(blast intro: tranclp.r_into_trancl tranclp_trans)
qed

lemma happens_before_change_prefix:
  assumes hb: "P,E  a ≤hb a'"
  and tsa_ok: "thread_start_actions_ok E'"
  and prefix: "ltake n E [≈] ltake n E'"
  and an: "enat a < n"
  and a'n: "enat a' < n"
  shows "P,E'  a ≤hb a'"
using hb an a'n
proof induct
  case (base a')
  thus ?case by(rule tranclp.r_into_trancl[where r="po_sw P E'", OF po_sw_change_prefix[OF _ prefix]])
next
  case (step a' a'')
  show ?case
  proof(cases "is_new_action (action_obs E a')  ¬ is_new_action (action_obs E a'')")
    case False
    from ‹po_sw P E a' a'' have "E  a' ≤a a''" by(rule po_sw_into_action_order)
    with ‹enat a'' < n False have "enat a' < n"
      by(safe elim!: action_orderE)(metis Suc_leI Suc_n_not_le_n enat_ord_simps(2) le_trans nat_neq_iff xtrans(10))+
    with ‹enat a < n have "P,E'  a ≤hb a'" by(rule step)
    moreover from ‹po_sw P E a' a'' prefix ‹enat a' < n ‹enat a'' < n
    have "po_sw P E' a' a''" by(rule po_sw_change_prefix)
    ultimately show ?thesis ..
  next
    case True
    then obtain new_a': "is_new_action (action_obs E a')"
      and "¬ is_new_action (action_obs E a'')" ..
    from P,E  a ≤hb a' new_a'
    have new_a: "is_new_action (action_obs E a)"
      and tid: "action_tid E a = action_tid E a'"
      and "a  a'" by(rule happens_before_new_actionD)+
    
    note tsa_ok moreover
    from porder_happens_before[of E P] have "a  actions E"
      by(rule porder_onE)(erule refl_onPD1, rule P,E  a ≤hb a')
    hence "a  actions E'" using an by(rule actions_change_prefix[OF _ prefix])
    moreover
    from ‹po_sw P E a' a'' refl_on_program_order[of E] refl_on_sync_order[of P E]
    have "a''  actions E"
      unfolding po_sw_def by(auto dest: refl_onPD2 elim!: sync_withE)
    hence "a''  actions E'" using ‹enat a'' < n by(rule actions_change_prefix[OF _ prefix])
    moreover
    from new_a action_obs_change_prefix[OF prefix an] 
    have "is_new_action (action_obs E' a)" by(cases) auto
    moreover
    from ¬ is_new_action (action_obs E a'') action_obs_change_prefix[OF prefix ‹enat a'' < n]
    have "¬ is_new_action (action_obs E' a'')" by(auto elim: is_new_action.cases)
    ultimately show "P,E'  a ≤hb a''" by(rule happens_before_new_not_new)
  qed
qed

lemma thread_start_actions_ok_change:
  assumes tsa: "thread_start_actions_ok E"
  and sim: "E [≈] E'"
  shows "thread_start_actions_ok E'"
proof(rule thread_start_actions_okI)
  fix a
  assume "a  actions E'" "¬ is_new_action (action_obs E' a)"
  from sim have len_eq: "llength E = llength E'" by(simp add: sim_actions_def)(rule llist_all2_llengthD)
  with sim have sim': "ltake (llength E) E [≈] ltake (llength E) E'" by(simp add: ltake_all)

  from a  actions E' len_eq have "enat a < llength E" by(simp add: actions_def)
  with a  actions E' sim'[symmetric] have "a  actions E" by(rule actions_change_prefix)
  moreover have "¬ is_new_action (action_obs E a)"
    using action_obs_change_prefix[OF sim' ‹enat a < llength E] ¬ is_new_action (action_obs E' a)
    by(auto elim!: is_new_action.cases)
  ultimately obtain i where "i  a" "action_obs E i = InitialThreadAction" "action_tid E i = action_tid E a"
    by(blast dest: thread_start_actions_okD[OF tsa])
  thus "i  a. action_obs E' i = InitialThreadAction  action_tid E' i = action_tid E' a"
    using action_tid_change_prefix[OF sim', of i] action_tid_change_prefix[OF sim', of a] ‹enat a < llength E
      action_obs_change_prefix[OF sim', of i]
    by(cases "llength E")(auto intro!: exI[where x=i])
qed

context executions_aux begin

lemma ℰ_new_same_addr_singleton:
  assumes E: "E  "
  shows "a. new_actions_for P E adal  {a}"
by(blast dest: ℰ_new_actions_for_fun[OF E])

lemma new_action_before_read:
  assumes E: "E  "
  and wf: "P  (E, ws) "
  and ra: "ra  read_actions E"
  and adal: "adal  action_loc P E ra"
  and new: "wa  new_actions_for P E adal"
  and sc: "a.  a < ra; a  read_actions E   P,E  a ↝mrw ws a"
  shows "wa < ra"
using ℰ_new_same_addr_singleton[OF E, of adal] init_before_read[OF E wf ra adal sc] new
by auto

lemma mrw_before:
  assumes E: "E  "
  and wf: "P  (E, ws) "
  and mrw: "P,E  r ↝mrw w"
  and sc: "a.  a < r; a  read_actions E   P,E  a ↝mrw ws a"
  shows "w < r"
using mrw read_actions_not_write_actions[of r E]
apply cases
apply(erule action_orderE)
 apply(erule (1) new_action_before_read[OF E wf])
  apply(simp add: new_actions_for_def)
 apply(erule (1) sc)
apply(cases "w = r")
apply auto
done

lemma mrw_change_prefix:
  assumes E': "E'  "
  and mrw: "P,E  r ↝mrw w"
  and tsa_ok: "thread_start_actions_ok E'"
  and prefix: "ltake n E [≈] ltake n E'"
  and an: "enat r < n"
  and a'n: "enat w < n"
  shows "P,E'  r ↝mrw w"
using mrw
proof cases
  fix adal
  assume r: "r  read_actions E"
    and adal_r: "adal  action_loc P E r"
    and war: "E  w ≤a r"
    and w: "w  write_actions E"
    and adal_w: "adal  action_loc P E w"
    and mrw: "wa'. wa'  write_actions E; adal  action_loc P E wa'
               E  wa' ≤a w  E  r ≤a wa'"
  show ?thesis
  proof(rule most_recent_write_for.intros)
    from r prefix an show r': "r  read_actions E'"
      by(rule read_actions_change_prefix)
    from adal_r show "adal  action_loc P E' r"
      by(simp add: action_loc_change_prefix[OF prefix[symmetric] an])
    from war prefix a'n an show "E'  w ≤a r" by(rule action_order_change_prefix)
    from w prefix a'n show w': "w  write_actions E'" by(rule write_actions_change_prefix)
    from adal_w show adal_w': "adal  action_loc P E' w" by(simp add: action_loc_change_prefix[OF prefix[symmetric] a'n])

    fix wa'
    assume wa': "wa'  write_actions E'" 
      and adal_wa': "adal  action_loc P E' wa'"
    show "E'  wa' ≤a w  E'  r ≤a wa'"
    proof(cases "enat wa' < n")
      case True
      note wa'n = this
      with wa' prefix[symmetric] have "wa'  write_actions E" by(rule write_actions_change_prefix)
      moreover from adal_wa' have "adal  action_loc P E wa'"
        by(simp add: action_loc_change_prefix[OF prefix wa'n])
      ultimately have "E  wa' ≤a w  E  r ≤a wa'" by(rule mrw)
      thus ?thesis
      proof
        assume "E  wa' ≤a w"
        hence "E'  wa' ≤a w" using prefix wa'n a'n by(rule action_order_change_prefix)
        thus ?thesis ..
      next
        assume "E  r ≤a wa'"
        hence "E'  r ≤a wa'" using prefix an wa'n by(rule action_order_change_prefix)
        thus ?thesis ..
      qed
    next
      case False note wa'n = this
      show ?thesis
      proof(cases "is_new_action (action_obs E' wa')")
        case False
        hence "E'  r ≤a wa'" using wa'n r' wa' an
          by(auto intro!: action_orderI) (metis enat_ord_code(1) linorder_le_cases order_le_less_trans)
        thus ?thesis ..
      next
        case True
        with wa' adal_wa' have new: "wa'  new_actions_for P E' adal" by(simp add: new_actions_for_def)
        show ?thesis
        proof(cases "is_new_action (action_obs E' w)")
          case True
          with adal_w' a'n w' have "w  new_actions_for P E' adal" by(simp add: new_actions_for_def)
          with E' new have "wa' = w" by(rule ℰ_new_actions_for_fun)
          thus ?thesis using w' by(auto intro: refl_onPD[OF refl_action_order])
        next
          case False
          with True wa' w' show ?thesis by(auto intro!: action_orderI)
        qed
      qed
    qed
  qed
qed

lemma action_order_read_before_write:
  assumes E: "E  " "P  (E, ws) "
  and ao: "E  w ≤a r"
  and r: "r  read_actions E"
  and w: "w  write_actions E"
  and adal: "adal  action_loc P E r" "adal  action_loc P E w"
  and sc: "a.  a < r; a  read_actions E   P,E  a ↝mrw ws a"
  shows "w < r"
using ao
proof(cases rule: action_orderE)
  case 1
  from init_before_read[OF E r adal(1) sc]
  obtain i where "i < r" "i  new_actions_for P E adal" by blast
  moreover from ‹is_new_action (action_obs E w) adal(2) w  actions E
  have "w  new_actions_for P E adal" by(simp add: new_actions_for_def)
  ultimately show "w < r" using E by(auto dest: ℰ_new_actions_for_fun)
next
  case 2
  with r w show ?thesis
    by(cases "w = r")(auto dest: read_actions_not_write_actions)
qed

end

end

Theory JMM_DRF

(*  Title:      JinjaThreads/MM/JMM_DRF.thy
    Author:     Andreas Lochbihler
*)

section ‹The data race free guarantee of the JMM›

theory JMM_DRF
imports
  JMM_Spec
begin

context drf begin

lemma drf_lemma:
  assumes wf: "P  (E, ws) "
  and E: "E  "
  and sync: "correctly_synchronized P "
  and read_before: "r. r  read_actions E  P,E  ws r ≤hb r"
  shows "sequentially_consistent P (E, ws)"
proof(rule ccontr)
  let ?Q = "{r. r  read_actions E  ¬ P,E  r ↝mrw ws r}"

  assume "¬ ?thesis"
  then obtain r where "r  read_actions E" "¬ P,E  r ↝mrw ws r"
    by(auto simp add: sequentially_consistent_def)
  hence "r  ?Q" by simp
  with wf_action_order[of E] obtain r' 
    where "r'  ?Q"  
    and "(action_order E)^** r' r"
    and r'_min: "a. (action_order E) a r'  a  ?Q"
    by(rule wfP_minimalE) blast
  from r'  ?Q have r': "r'  read_actions E"
    and not_mrw: "¬ P,E  r' ↝mrw ws r'" by blast+

  from r' obtain ad al v where obs_r': "action_obs E r' = NormalAction (ReadMem ad al v)"
    by(cases) auto
  from wf have ws: "is_write_seen P E ws" 
    and tsa_ok: "thread_start_actions_ok E" 
    by(rule wf_exec_is_write_seenD wf_exec_thread_start_actions_okD)+
  from is_write_seenD[OF ws r' obs_r']
  have ws_r: "ws r'  write_actions E"
    and adal: "(ad, al)  action_loc P E (ws r')"
    and v: "v = value_written P E (ws r') (ad, al)"
    and not_hb: "¬ P,E  r' ≤hb ws r'" by auto
  from r' have "P,E  ws r' ≤hb r'" by(rule read_before)
  hence "E  ws r' ≤a r'" by(rule happens_before_into_action_order)
  from not_mrw
  have "w'. w'  write_actions E  (ad, al)  action_loc P E w'  
      ¬ P,E  w' ≤hb ws r'  ¬ P,E  w' ≤so ws r'  
      ¬ P,E  r' ≤hb w'  ¬ P,E  r' ≤so w'  E  w' ≤a r'"
  proof(rule contrapos_np)
    assume inbetween: "¬ ?thesis"
    note r'
    moreover from obs_r' have "(ad, al)  action_loc P E r'" by simp
    moreover note E  ws r' ≤a r' ws_r adal
    moreover
    { fix w'
      assume "w'  write_actions E" "(ad, al)  action_loc P E w'"
      with inbetween have "P,E  w' ≤hb ws r'  P,E  w' ≤so ws r'  P,E  r' ≤hb w'  P,E  r' ≤so w'  ¬ E  w' ≤a r'" by simp
      moreover from total_onPD[OF total_action_order, of w' E r'] w'  write_actions E r'
      have "E  w' ≤a r'  E  r' ≤a w'" by(auto dest: read_actions_not_write_actions)
      ultimately have "E  w' ≤a ws r'  E  r' ≤a w'" unfolding sync_order_def
        by(blast intro: happens_before_into_action_order) }
    ultimately show "P,E  r' ↝mrw ws r'" by(rule most_recent_write_for.intros)
  qed
  then obtain w' where w': "w'  write_actions E"
    and adal_w': "(ad, al)  action_loc P E w'"
    and "¬ P,E  w' ≤hb ws r'" "¬ P,E  r' ≤hb w'" "E  w' ≤a r'" 
    and so: "¬ P,E  w' ≤so ws r'" "¬ P,E  r' ≤so w'" by blast

  have "ws r'  w'" using ¬ P,E  w' ≤hb ws r' ws_r
    by(auto intro: happens_before_refl)

  have vol: "¬ is_volatile P al"
  proof
    assume vol_al: "is_volatile P al"
    with r' obs_r' have "r'  sactions P E" by cases(rule sactionsI, simp_all)
    moreover from w' vol_al adal_w' have "w'  sactions P E" 
      by(cases)(auto intro: sactionsI elim!: is_write_action.cases)
    ultimately have "P,E  w' ≤so r'  w' = r'  P,E  r' ≤so w'"
      using total_sync_order[of P E] by(blast dest: total_onPD)
    moreover have "w'  r'" using w' r' by(auto dest: read_actions_not_write_actions)
    ultimately have "P,E  w' ≤so r'" using ¬ P,E  r' ≤so w' by simp
    moreover from ws_r vol_al adal have "ws r'  sactions P E" 
      by(cases)(auto intro: sactionsI elim!: is_write_action.cases)
    with total_sync_order[of P E] w'  sactions P E ¬ P,E  w' ≤so ws r' ws r'  w'
    have "P,E  ws r' ≤so w'" by(blast dest: total_onPD)
    ultimately show False
      using is_write_seenD[OF ws r' obs_r'] w' adal_w' vol_al ws r'  w' by auto
  qed

  { fix a
    assume "a < r'" and "a  read_actions E"
    hence "(action_order E) a r'" using r' obs_r' by(auto intro: action_orderI)
    from r'_min[OF this] a  read_actions E
    have "P,E  a ↝mrw ws a" by simp }

  from ℰ_sequential_completion[OF E wf this, of r'] r'
  obtain E' ws' where "E'  " "P  (E', ws') "
    and eq: "ltake (enat r') E = ltake (enat r') E'"
    and sc': "sequentially_consistent P (E', ws')" 
    and r'': "action_tid E r' = action_tid E' r'" "action_obs E r'  action_obs E' r'"
    and "r'  actions E'"
    by auto

  from P  (E', ws')  have tsa_ok': "thread_start_actions_ok E'"
    by(rule wf_exec_thread_start_actions_okD)

  from r'  read_actions E have "enat r' < llength E" by(auto elim: read_actions.cases actionsE)
  moreover from r'  actions E' have "enat r' < llength E'" by(auto elim: actionsE)
  ultimately have eq': "ltake (enat (Suc r')) E [≈] ltake (enat (Suc r')) E'"
    using eq[THEN eq_into_sim_actions] r''
    by(auto simp add: ltake_Suc_conv_snoc_lnth sim_actions_def split_beta action_tid_def action_obs_def intro!: llist_all2_lappendI)
  from r' have r'': "r'  read_actions E'"
    by(rule read_actions_change_prefix[OF _eq']) simp
  from obs_r' have "(ad, al)  action_loc P E r'" by simp
  hence adal_r'': "(ad, al)  action_loc P E' r'"
    by(subst (asm) action_loc_change_prefix[OF eq']) simp

  from ¬ P,E  w' ≤hb ws r'
  have "¬ is_new_action (action_obs E w')"
  proof(rule contrapos_nn)
    assume new_w': "is_new_action (action_obs E w')"
    show "P,E  w' ≤hb ws r'"
    proof(cases "is_new_action (action_obs E (ws r'))")
      case True
      with adal new_w' adal_w' w' ws_r
      have "ws r'  new_actions_for P E (ad, al)" "w'  new_actions_for P E (ad, al)"
        by(auto simp add: new_actions_for_def)
      with E   have "ws r' = w'" by(rule ℰ_new_actions_for_fun)
      thus ?thesis using w' by(auto intro: happens_before_refl)
    next
      case False
      with tsa_ok w' ws_r new_w'
      show ?thesis by(auto intro: happens_before_new_not_new)
    qed
  qed
  with E  w' ≤a r' have "w'  r'" by(auto elim!: action_orderE)
  moreover from w' r' have "w'  r'" by(auto intro: read_actions_not_write_actions)
  ultimately have "w' < r'" by simp
  with w' have "w'  write_actions E'"
    by(auto intro: write_actions_change_prefix[OF _ eq'])
  hence "w'  actions E'" by simp

  from adal_w' w' < r'
  have "(ad, al)  action_loc P E' w'"
    by(subst action_loc_change_prefix[symmetric, OF eq']) simp_all
  
  from vol r'  read_actions E' w'  write_actions E' (ad, al)  action_loc P E' w' adal_r''
  have "P,E'  r'  w'" unfolding non_volatile_conflict_def by auto
  with sync E'   P  (E', ws')  sc' r'  actions E' w'  actions E'
  have hb'_r'_w': "P,E'  r' ≤hb w'  P,E'  w' ≤hb r'"
    by(rule correctly_synchronizedD[rule_format])
  hence "P,E  r' ≤hb w'  P,E  w' ≤hb r'" using w' < r'
    by(auto intro: happens_before_change_prefix[OF _ tsa_ok eq'[symmetric]])
  with ¬ P,E  r' ≤hb w' have "P,E  w' ≤hb r'" by simp
  
  have "P,E  ws r' ≤hb w'"
  proof(cases "is_new_action (action_obs E (ws r'))")
    case False
    with E  ws r' ≤a r' have "ws r'  r'" by(auto elim!: action_orderE)
    moreover from ws_r r' have "ws r'  r'" by(auto dest: read_actions_not_write_actions)
    ultimately have "ws r' < r'" by simp
    with ws_r have "ws r'  write_actions E'"
      by(auto intro: write_actions_change_prefix[OF _ eq'])
    hence "ws r'  actions E'" by simp
    
    from adal ws r' < r'
    have "(ad, al)  action_loc P E' (ws r')"
      by(subst action_loc_change_prefix[symmetric, OF eq']) simp_all
    hence "P,E'  ws r'  w'"
      using ws r'  write_actions E' w'  write_actions E' (ad, al)  action_loc P E' w' vol
      unfolding non_volatile_conflict_def by auto
    with sync E'   P  (E', ws')  sc' ws r'  actions E' w'  actions E'
    have "P,E'  ws r' ≤hb w'  P,E'  w' ≤hb ws r'"
      by(rule correctly_synchronizedD[rule_format])
    thus "P,E  ws r' ≤hb w'" using w' < r' ws r' < r' ¬ P,E  w' ≤hb ws r'
      by(auto dest: happens_before_change_prefix[OF _ tsa_ok eq'[symmetric]])
  next
    case True 
    with tsa_ok ws_r w' ¬ is_new_action (action_obs E w')
    show "P,E  ws r' ≤hb w'" by(auto intro: happens_before_new_not_new)
  qed
  moreover
  from wf have "is_write_seen P E ws" by(rule wf_exec_is_write_seenD)
  ultimately have "w' = ws r'"
    using is_write_seenD[OF ‹is_write_seen P E ws r'  read_actions E obs_r']
      w'  write_actions E (ad, al)  action_loc P E w' P,E  w' ≤hb r'
    by auto
  with porder_happens_before[of E P] ¬ P,E  w' ≤hb ws r' ws_r show False
    by(auto dest: refl_onPD[where a="ws r'"] elim!: porder_onE)
qed

lemma justified_action_committedD:
  assumes justified: "P  (E, ws) weakly_justified_by J"
  and a: "a  actions E"
  obtains n a' where "a = action_translation (J n) a'" "a'  committed (J n)"
proof(atomize_elim)
  from justified have "actions E = (n. action_translation (J n) ` committed (J n))"
    by(simp add: is_commit_sequence_def)
  with a show "n a'. a = action_translation (J n) a'  a'  committed (J n)" by auto
qed

theorem drf_weak:
  assumes sync: "correctly_synchronized P "
  and legal: "weakly_legal_execution P  (E, ws)"
  shows "sequentially_consistent P (E, ws)"
using legal_wf_execD[OF legal] legal_ℰD[OF legal] sync
proof(rule drf_lemma)
  fix r
  assume "r  read_actions E"

  from legal obtain J where E: "E  "
    and wf_exec: "P  (E, ws) "
    and J: "P  (E, ws) weakly_justified_by J"
    and range_J: "range (justifying_exec  J)  "
    by(rule legal_executionE)

  let ?E = "λn. justifying_exec (J n)"
    and ?ws = "λn. justifying_ws (J n)"
    and ?C = "λn. committed (J n)"
    and  = "λn. action_translation (J n)"
  
  from r  read_actions E have "r  actions E" by simp
  with J obtain n r' where r: "r = action_translation (J n) r'"
    and r': "r'  ?C n" by(rule justified_action_committedD)

  note r  read_actions E
  moreover from J have wfan: "wf_action_translation_on (?E n) E (?C n) ( n)"
    by(simp add: wf_action_translations_def)
  hence "action_obs (?E n) r'  action_obs E r" using r' unfolding r
    by(blast dest: wf_action_translation_on_actionD)
  moreover from J r' have "r'  actions (?E n)"
    by(auto simp add: committed_subset_actions_def)
  ultimately have "r'  read_actions (?E n)" unfolding r 
    by cases(auto intro: read_actions.intros)
  hence "P,E  ws ( n r') ≤hb  n r'" using r'  ?C n
  proof(induct n arbitrary: r')
    case 0
    from J have "?C 0 = {}" by(simp add: is_commit_sequence_def)
    with 0 have False by simp
    thus ?case ..
  next
    case (Suc n r)
    note r = r  read_actions (?E (Suc n))
    from J have wfan: "wf_action_translation_on (?E n) E (?C n) ( n)"
      and wfaSn: "wf_action_translation_on (?E (Suc n)) E (?C (Suc n)) ( (Suc n))"
      by(simp_all add: wf_action_translations_def)

    from wfaSn have injSn: "inj_on ( (Suc n)) (actions (?E (Suc n)))"
      by(rule wf_action_translation_on_inj_onD)
    from J have C_sub_A: "?C (Suc n)  actions (?E (Suc n))"
      by(simp add: committed_subset_actions_def)

    from J have wf: "P  (?E (Suc n), ?ws (Suc n)) " by(simp add: justification_well_formed_def)
    moreover from range_J have "?E (Suc n)  " by auto
    ultimately have sc: "sequentially_consistent P (?E (Suc n), ?ws (Suc n))" using sync
    proof(rule drf_lemma)
      fix r'
      assume r': "r'  read_actions (?E (Suc n))"
      hence "r'  actions (?E (Suc n))" by simp
      
      show "P,?E (Suc n)  ?ws (Suc n) r' ≤hb r'"
      proof(cases " (Suc n) r'   n ` ?C n")
        case True
        then obtain r'' where r'': "r''  ?C n"
          and r'_r'': " (Suc n) r' =  n r''" by(auto)
        from r'' wfan have "action_tid (?E n) r'' = action_tid E ( n r'')"
          and "action_obs (?E n) r''  action_obs E ( n r'')"
          by(blast dest: wf_action_translation_on_actionD)+
        moreover from J have " n ` ?C n   (Suc n) ` ?C (Suc n)"
          by(simp add: is_commit_sequence_def)
        with r'' have " (Suc n) r'   (Suc n) ` ?C (Suc n)" 
          unfolding r'_r'' by auto
        hence "r'  ?C (Suc n)"
          unfolding inj_on_image_mem_iff[OF injSn C_sub_A r'  actions (?E (Suc n))] .
        with wfaSn have "action_tid (?E (Suc n)) r' = action_tid E ( (Suc n) r')"
          and "action_obs (?E (Suc n)) r'  action_obs E ( (Suc n) r')"
          by(blast dest: wf_action_translation_on_actionD)+
        ultimately have tid: "action_tid (?E n) r'' = action_tid (?E (Suc n)) r'"
          and obs: "action_obs (?E n) r''  action_obs (?E (Suc n)) r'"
          unfolding r'_r'' by(auto intro: sim_action_trans sim_action_sym)
        
        from J have "?C n  actions (?E n)" by(simp add: committed_subset_actions_def)
        with r'' have "r''  actions (?E n)" by blast
        with r' obs have "r''  read_actions (?E n)"
          by cases(auto intro: read_actions.intros)
        hence hb'': "P,E  ws ( n r'') ≤hb  n r''"
          using r''  ?C n by(rule Suc)

        have r_conv_inv: "r' = inv_into (actions (?E (Suc n))) ( (Suc n)) ( n r'')"
          using r'  actions (?E (Suc n)) unfolding r'_r''[symmetric]
          by(simp add: inv_into_f_f[OF injSn])
        with r''  ?C n r' J r''  read_actions (?E n)
        have ws_eq[symmetric]: " (Suc n) (?ws (Suc n) r') = ws ( n r'')"
          by(simp add: write_seen_committed_def Let_def)
        with r'_r''[symmetric] hb'' have "P,E   (Suc n) (?ws (Suc n) r') ≤hb  (Suc n) r'" by simp
        
        moreover

        from J r' r'  committed (J (Suc n))
        have "ws ( (Suc n) r')   (Suc n) ` ?C (Suc n)"
          by(rule weakly_justified_write_seen_hb_read_committed)
        then obtain w' where w': "ws ( (Suc n) r') =  (Suc n) w'"
          and committed_w': "w'  ?C (Suc n)" by blast
        with C_sub_A have w'_action: "w'  actions (?E (Suc n))" by auto

        hence w'_def: "w' = inv_into (actions (?E (Suc n))) ( (Suc n)) (ws ( (Suc n) r'))"
          using injSn unfolding w' by simp

        from J r'  r'  committed (J (Suc n)) 
        have hb_eq: "P,E  ws ( (Suc n) r') ≤hb  (Suc n) r'  P,?E (Suc n)  w' ≤hb r'"
          unfolding w'_def by(simp add: happens_before_committed_weak_def)

        from r' obtain ad al v where "action_obs (?E (Suc n)) r' = NormalAction (ReadMem ad al v)" by(cases)
        from is_write_seenD[OF wf_exec_is_write_seenD[OF wf] r' this]
        have "?ws (Suc n) r'  actions (?E (Suc n))" by(auto)
        with injSn have "w' = ?ws (Suc n) r'"
          unfolding w'_def ws_eq[folded r'_r''] by(rule inv_into_f_f)
        thus ?thesis using hb'' hb_eq w'_action r'_r''[symmetric] w' injSn by simp
      next
        case False
        with J r' show ?thesis by(auto simp add: uncommitted_reads_see_hb_def)
      qed
    qed

    from r have "r  actions (?E (Suc n))" by simp
    let ?w = "inv_into (actions (?E (Suc n))) ( (Suc n)) (ws ( (Suc n) r))"
    from J r r  ?C (Suc n) have ws_rE_comm: "ws ( (Suc n) r)   (Suc n) ` ?C (Suc n)"
      by(rule weakly_justified_write_seen_hb_read_committed)
    hence "?w  ?C (Suc n)" using C_sub_A by(auto simp add: inv_into_f_f[OF injSn])
    with C_sub_A have w: "?w  actions (?E (Suc n))" by blast

    from ws_rE_comm C_sub_A have w_eq: " (Suc n) ?w = ws ( (Suc n) r)"
      by(auto simp: f_inv_into_f[where f=" (Suc n)"])
    from r obtain ad al v
      where obsr: "action_obs (?E (Suc n)) r = NormalAction (ReadMem ad al v)" by cases
    hence adal_r: "(ad, al)  action_loc P (?E (Suc n)) r" by simp
    from J wfaSn r  ?C (Suc n)
    have obs_sim: "action_obs (?E (Suc n)) r  action_obs E ( (Suc n) r)" " (Suc n) r  actions E"
      by(auto dest: wf_action_translation_on_actionD simp add: committed_subset_actions_def is_commit_sequence_def)
    with obsr have rE: " (Suc n) r  read_actions E" by(fastforce intro: read_actions.intros)
    from obs_sim obsr obtain v' 
      where obsrE: "action_obs E ( (Suc n) r) = NormalAction (ReadMem ad al v')" by auto
    from wf_exec have "is_write_seen P E ws" by(rule wf_exec_is_write_seenD)
    from is_write_seenD[OF this rE obsrE]
    have "ws ( (Suc n) r)  write_actions E" 
      and "(ad, al)  action_loc P E (ws ( (Suc n) r))"
      and nhb: "¬ P,E   (Suc n) r ≤hb ws ( (Suc n) r)" 
      and vol: "is_volatile P al  ¬ P,E   (Suc n) r ≤so ws ( (Suc n) r)" by simp_all

    show ?case
    proof(cases "is_volatile P al")
      case False

      from wf_action_translation_on_actionD[OF wfaSn ?w  ?C (Suc n)]
      have "action_obs (?E (Suc n)) ?w  action_obs E ( (Suc n) ?w)" by simp
      with w_eq have obs_sim_w: "action_obs (?E (Suc n)) ?w  action_obs E (ws ( (Suc n) r))" by simp
      with ws ( (Suc n) r)  write_actions E ?w  actions (?E (Suc n))
      have "?w  write_actions (?E (Suc n))"
        by cases(fastforce intro: write_actions.intros is_write_action.intros elim!: is_write_action.cases)
      from (ad, al)  action_loc P E (ws ( (Suc n) r)) obs_sim_w 
      have "(ad, al)  action_loc P (?E (Suc n)) ?w" by cases(auto intro: action_loc_aux_intros)
      with r adal_r ?w  write_actions (?E (Suc n)) False
      have "P,?E (Suc n)  r  ?w" by(auto simp add: non_volatile_conflict_def)
      with sc r  actions (?E (Suc n)) w
      have "P,?E (Suc n)  r ≤hb ?w  P,?E (Suc n)  ?w ≤hb r"
        by(rule correctly_synchronizedD[rule_format, OF sync ?E (Suc n)   wf])
      moreover from J r r  ?C (Suc n) 
      have "P,?E (Suc n)  ?w ≤hb r  P,E  ws ( (Suc n) r) ≤hb  (Suc n) r"
        and "¬ P,?E (Suc n)  r ≤hb ?w"
        by(simp_all add: happens_before_committed_weak_def)
      ultimately show ?thesis by auto
    next
      case True
      with rE obsrE have " (Suc n) r  sactions P E" by cases (auto intro: sactionsI)
      moreover from ws ( (Suc n) r)  write_actions E (ad, al)  action_loc P E (ws ( (Suc n) r)) True 
      have "ws ( (Suc n) r)  sactions P E" by cases(auto intro!: sactionsI elim: is_write_action.cases)
      moreover have " (Suc n) r  ws ( (Suc n) r)"
        using ws ( (Suc n) r)  write_actions E rE by(auto dest: read_actions_not_write_actions)
      ultimately have "P,E  ws ( (Suc n) r) ≤so  (Suc n) r"
        using total_sync_order[of P E] vol[OF True] by(auto dest: total_onPD)
      moreover from ws ( (Suc n) r)  write_actions E (ad, al)  action_loc P E (ws ( (Suc n) r)) True
      have "P  (action_tid E (ws ( (Suc n) r)), action_obs E (ws ( (Suc n) r))) ↝sw
        (action_tid E ( (Suc n) r), action_obs E ( (Suc n) r))"
        by cases(fastforce elim!: is_write_action.cases intro: synchronizes_with.intros addr_locsI simp add: obsrE)
      ultimately have "P,E  ws ( (Suc n) r) ≤sw  (Suc n) r" by(rule sync_withI)
      thus ?thesis unfolding po_sw_def by blast
    qed
  qed
  thus "P,E  ws r ≤hb r" unfolding r .
qed

corollary drf:
  " correctly_synchronized P ; legal_execution P  (E, ws) 
   sequentially_consistent P (E, ws)"
by(erule drf_weak)(rule legal_imp_weakly_legal_execution)

end

end

Theory Non_Speculative

(*  Title:      JinjaThreads/MM/Non_Speculative.thy
    Author:     Andreas Lochbihler
*)

section ‹Non-speculative prefixes of executions›

theory Non_Speculative imports
  JMM_Spec
  "../Framework/FWLTS"
begin

declare addr_locsI [simp]

subsection ‹Previously written values›

fun w_value :: 
  "'m prog  (('addr × addr_loc)  'addr val set)  ('addr, 'thread_id) obs_event action
   (('addr × addr_loc)  'addr val set)"
where
  "w_value P vs (NormalAction (WriteMem ad al v)) = vs((ad, al) := insert v (vs (ad, al)))"
| "w_value P vs (NormalAction (NewHeapElem ad hT)) =
   (λ(ad', al). if ad = ad'  al  addr_locs P hT
                then insert (addr_loc_default P hT al) (vs (ad, al))
                else vs (ad', al))"
| "w_value P vs _ = vs"

lemma w_value_cases:
  obtains ad al v where "x = NormalAction (WriteMem ad al v)"
  | ad hT where "x = NormalAction (NewHeapElem ad hT)"
  | ad M vs v where "x = NormalAction (ExternalCall ad M vs v)"
  | ad al v where "x = NormalAction (ReadMem ad al v)"
  | t where "x = NormalAction (ThreadStart t)"
  | t where "x = NormalAction (ThreadJoin t)"
  | ad where "x = NormalAction (SyncLock ad)"
  | ad where "x = NormalAction (SyncUnlock ad)"
  | t where "x = NormalAction (ObsInterrupt t)"
  | t where "x = NormalAction (ObsInterrupted t)"
  | "x = InitialThreadAction"
  | "x = ThreadFinishAction"
by pat_completeness

abbreviation w_values ::
  "'m prog  (('addr × addr_loc)  'addr val set)  ('addr, 'thread_id) obs_event action list
   (('addr × addr_loc)  'addr val set)"
where "w_values P  foldl (w_value P)"

lemma in_w_valuesD:
  assumes w: "v  w_values P vs0 obs (ad, al)"
  and v: "v  vs0 (ad, al)"
  shows "obs' wa obs''. obs = obs' @ wa # obs''  is_write_action wa  (ad, al)  action_loc_aux P wa 
            value_written_aux P wa al = v"
  (is "?concl obs")
using w
proof(induction obs rule: rev_induct)
  case Nil thus ?case using v by simp
next
  case (snoc ob obs)
  from snoc.IH show ?case
  proof(cases "v  w_values P vs0 obs (ad, al)")
    case False thus ?thesis using v  w_values P vs0 (obs @ [ob]) (ad, al)
      by(cases ob rule: w_value_cases)(auto 4 4 intro: action_loc_aux_intros split: if_split_asm simp add: addr_locs_def split: htype.split_asm)
  qed fastforce
qed

lemma w_values_WriteMemD:
  assumes "NormalAction (WriteMem ad al v)  set obs"
  shows "v  w_values P vs0 obs (ad, al)"
using assms
apply(induct obs rule: rev_induct)
 apply simp
apply clarsimp
apply(erule disjE)
 apply clarsimp
apply clarsimp
apply(case_tac x rule: w_value_cases)
apply auto
done


lemma w_values_new_actionD:
  assumes "NormalAction (NewHeapElem ad hT)  set obs" "(ad, al)  action_loc_aux P (NormalAction (NewHeapElem ad hT))"
  shows "addr_loc_default P hT al  w_values P vs0 obs (ad, al)"
using assms
apply(induct obs rule: rev_induct)
 apply simp
apply clarsimp
apply(rename_tac w' obs)
apply(case_tac w' rule: w_value_cases)
apply(auto simp add: split_beta)
done

lemma w_value_mono: "vs0 adal  w_value P vs0 ob adal"
by(cases ob rule: w_value_cases)(auto split: if_split_asm simp add: split_beta)

lemma w_values_mono: "vs0 adal  w_values P vs0 obs adal"
by(induct obs rule: rev_induct)(auto del: subsetI intro: w_value_mono subset_trans)

lemma w_value_greater: "vs0  w_value P vs0 ob"
by(rule le_funI)(rule w_value_mono)

lemma w_values_greater: "vs0  w_values P vs0 obs"
by(rule le_funI)(rule w_values_mono)

lemma w_values_eq_emptyD:
  assumes "w_values P vs0 obs adal = {}"
  and "w  set obs" and "is_write_action w" and "adal  action_loc_aux P w"
  shows False
using assms(4) assms(1-3)
apply(cases rule: action_loc_aux_cases)
apply(auto dest!: w_values_new_actionD[where ?vs0.0=vs0 and P=P] w_values_WriteMemD[where ?vs0.0=vs0 and P=P])
apply blast
done

subsection ‹Coinductive version of non-speculative prefixes›

coinductive non_speculative :: 
  "'m prog  ('addr × addr_loc  'addr val set)  ('addr, 'thread_id) obs_event action llist  bool"
for P :: "'m prog" 
where
  LNil: "non_speculative P vs LNil"
| LCons:
  " case ob of NormalAction (ReadMem ad al v)  v  vs (ad, al) | _  True;
     non_speculative P (w_value P vs ob) obs  
   non_speculative P vs (LCons ob obs)"

inductive_simps non_speculative_simps [simp]:
  "non_speculative P vs LNil"
  "non_speculative P vs (LCons ob obs)"

lemma non_speculative_lappend:
  assumes "lfinite obs"
  shows "non_speculative P vs (lappend obs obs') 
         non_speculative P vs obs  non_speculative P (w_values P vs (list_of obs)) obs'"
  (is "?concl vs obs")
using assms
proof(induct arbitrary: vs)
  case lfinite_LNil thus ?case by simp
next
  case (lfinite_LConsI obs ob)
  have "?concl (w_value P vs ob) obs" by fact
  thus ?case using ‹lfinite obs by simp
qed

lemma
  assumes "non_speculative P vs obs"
  shows non_speculative_ltake: "non_speculative P vs (ltake n obs)" (is ?thesis1)
  and non_speculative_ldrop: "non_speculative P (w_values P vs (list_of (ltake n obs))) (ldrop n obs)" (is ?thesis2)
proof -
  note assms
  also have "obs = lappend (ltake n obs) (ldrop n obs)" by(simp add: lappend_ltake_ldrop)
  finally have "?thesis1  ?thesis2"
    by(cases n)(simp_all add: non_speculative_lappend del: lappend_ltake_enat_ldropn)
  thus ?thesis1 ?thesis2 by blast+
qed

lemma non_speculative_coinduct_append [consumes 1, case_names non_speculative, case_conclusion non_speculative LNil lappend]:
  assumes major: "X vs obs"
  and step: "vs obs. X vs obs 
     obs = LNil 
       (obs' obs''. obs = lappend obs' obs''  obs'  LNil  non_speculative P vs obs' 
                    (lfinite obs'  (X (w_values P vs (list_of obs')) obs''  
                                       non_speculative P (w_values P vs (list_of obs')) obs'')))"
    (is "vs obs. _  _  ?step vs obs")
  shows "non_speculative P vs obs"
proof -
  from major
  have "obs' obs''. obs = lappend (llist_of obs') obs''  non_speculative P vs (llist_of obs')  
                     X (w_values P vs obs') obs''"
    by(auto intro: exI[where x="[]"])
  thus ?thesis
  proof(coinduct)
    case (non_speculative vs obs)
    then obtain obs' obs'' 
      where obs: "obs = lappend (llist_of obs') obs''"
      and sc_obs': "non_speculative P vs (llist_of obs')"
      and X: "X (w_values P vs obs') obs''" by blast

    show ?case
    proof(cases obs')
      case Nil
      with X have "X vs obs''" by simp
      from step[OF this] show ?thesis
      proof
        assume "obs'' = LNil" 
        with Nil obs show ?thesis by simp
      next
        assume "?step vs obs''"
        then obtain obs''' obs'''' 
          where obs'': "obs'' = lappend obs''' obs''''" and "obs'''  LNil"
          and sc_obs''': "non_speculative P vs obs'''" 
          and fin: "lfinite obs'''  X (w_values P vs (list_of obs''')) obs'''' 
                                      non_speculative P (w_values P vs (list_of obs''')) obs''''"
          by blast
        from obs'''  LNil› obtain ob obs''''' where obs''': "obs''' = LCons ob obs'''''"
          unfolding neq_LNil_conv by blast
        with Nil obs'' obs have concl1: "obs = LCons ob (lappend obs''''' obs'''')" by simp
        have concl2: "case ob of NormalAction (ReadMem ad al v)  v  vs (ad, al) | _  True"
          using sc_obs''' obs''' by simp

        show ?thesis
        proof(cases "lfinite obs'''")
          case False
          hence "lappend obs''''' obs'''' = obs'''''" using obs''' by(simp add: lappend_inf)
          hence "non_speculative P (w_value P vs ob) (lappend obs''''' obs'''')" 
            using sc_obs''' obs''' by simp
          with concl1 concl2 have ?LCons by blast
          thus ?thesis by simp
        next
          case True
          with obs''' obtain obs'''''' where obs''''': "obs''''' = llist_of obs''''''"
            by simp(auto simp add: lfinite_eq_range_llist_of)
          from fin[OF True] have "?LCons"
          proof
            assume X: "X (w_values P vs (list_of obs''')) obs''''"
            hence "X (w_values P (w_value P vs ob) obs'''''') obs''''"
              using obs''''' obs''' by simp
            moreover from obs'''''
            have "lappend obs''''' obs'''' = lappend (llist_of obs'''''') obs''''" by simp
            moreover have "non_speculative P (w_value P vs ob) (llist_of obs'''''')" 
              using sc_obs''' obs''' obs''''' by simp
            ultimately show ?thesis using concl1 concl2 by blast
          next
            assume "non_speculative P (w_values P vs (list_of obs''')) obs''''"
            with sc_obs''' obs''''' obs'''
            have "non_speculative P (w_value P vs ob) (lappend obs''''' obs'''')"
              by(simp add: non_speculative_lappend)
            with concl1 concl2 show ?thesis by blast
          qed
          thus ?thesis by simp
        qed
      qed
    next
      case (Cons ob obs''')
      hence "obs = LCons ob (lappend (llist_of obs''') obs'')"
        using obs by simp
      moreover from sc_obs' Cons 
      have "case ob of NormalAction (ReadMem ad al v)  v  vs (ad, al) | _  True"
        and "non_speculative P (w_value P vs ob) (llist_of obs''')" by simp_all
      moreover from X Cons have "X (w_values P (w_value P vs ob) obs''') obs''" by simp
      ultimately show ?thesis by blast
    qed
  qed
qed

lemma non_speculative_coinduct_append_wf
  [consumes 2, case_names non_speculative, case_conclusion non_speculative LNil lappend]:
  assumes major: "X vs obs a"
  and wf: "wf R"
  and step: "vs obs a. X vs obs a
     obs = LNil 
       (obs' obs'' a'. obs = lappend obs' obs''  non_speculative P vs obs'  (obs' = LNil  (a', a)  R) 
                        (lfinite obs'  X (w_values P vs (list_of obs')) obs'' a' 
                                          non_speculative P (w_values P vs (list_of obs')) obs''))"
    (is "vs obs a. _  _  ?step vs obs a")
  shows "non_speculative P vs obs"
proof -
  { fix vs obs a
    assume "X vs obs a"
    with wf
    have "obs = LNil  (obs' obs''. obs = lappend obs' obs''  obs'  LNil  non_speculative P vs obs' 
          (lfinite obs'  (a. X (w_values P vs (list_of obs')) obs'' a)  
                            non_speculative P (w_values P vs (list_of obs')) obs''))"
      (is "_  ?step_concl vs obs")
    proof(induct a arbitrary: vs obs rule: wf_induct[consumes 1, case_names wf])
      case (wf a)
      note IH = wf.hyps[rule_format]
      from step[OF X vs obs a]
      show ?case
      proof
        assume "obs = LNil" thus ?thesis ..
      next
        assume "?step vs obs a"
        then obtain obs' obs'' a'
          where obs: "obs = lappend obs' obs''"
          and sc_obs': "non_speculative P vs obs'"
          and decr: "obs' = LNil  (a', a)  R"
          and fin: "lfinite obs'  
                    X (w_values P vs (list_of obs')) obs'' a' 
                    non_speculative P (w_values P vs (list_of obs')) obs''"
          by blast
        show ?case
        proof(cases "obs' = LNil")
          case True
          hence "lfinite obs'" by simp
          from fin[OF this] show ?thesis
          proof
            assume X: "X (w_values P vs (list_of obs')) obs'' a'"
            from True have "(a', a)  R" by(rule decr)
            from IH[OF this X] show ?thesis
            proof
              assume "obs'' = LNil"
              with True obs have "obs = LNil" by simp
              thus ?thesis ..
            next
              assume "?step_concl (w_values P vs (list_of obs')) obs''"
              hence "?step_concl vs obs" using True obs by simp
              thus ?thesis ..
            qed
          next
            assume "non_speculative P (w_values P vs (list_of obs')) obs''"
            thus ?thesis using obs True
              by cases(auto cong: action.case_cong obs_event.case_cong intro: exI[where x="LCons x LNil" for x])
          qed
        next
          case False
          with obs sc_obs' fin show ?thesis by auto
        qed
      qed
    qed }
  note step' = this

  from major show ?thesis
  proof(coinduction arbitrary: vs obs a rule: non_speculative_coinduct_append)
    case (non_speculative vs obs)
    thus ?case by simp(rule step')
  qed
qed

lemma non_speculative_nthI:
  "(i ad al v. 
     enat i < llength obs; lnth obs i = NormalAction (ReadMem ad al v);
      non_speculative P vs (ltake (enat i) obs)  
     v  w_values P vs (list_of (ltake (enat i) obs)) (ad, al))
   non_speculative P vs obs"
proof(coinduction arbitrary: vs obs rule: non_speculative.coinduct)
  case (non_speculative vs obs)
  hence nth:
    "i ad al v.  enat i < llength obs; lnth obs i = NormalAction (ReadMem ad al v); 
                   non_speculative P vs (ltake (enat i) obs)  
     v  w_values P vs (list_of (ltake (enat i) obs)) (ad, al)" by blast
  show ?case
  proof(cases obs)
    case LNil thus ?thesis by simp
  next
    case (LCons ob obs')
    { fix ad al v
      assume "ob = NormalAction (ReadMem ad al v)"
      with nth[of 0 ad al v] LCons
      have "v  vs (ad, al)" by(simp add: zero_enat_def[symmetric]) }
    note base = this
    moreover { 
      fix i ad al v
      assume "enat i < llength obs'" "lnth obs' i = NormalAction (ReadMem ad al v)"
        and "non_speculative P (w_value P vs ob) (ltake (enat i) obs')"
      with LCons nth[of "Suc i" ad al v] base
      have "v  w_values P (w_value P vs ob) (list_of (ltake (enat i) obs')) (ad, al)"
        by(clarsimp simp add: eSuc_enat[symmetric] split: obs_event.split action.split) }
    ultimately have ?LCons using LCons by(simp split: action.split obs_event.split)
    thus ?thesis ..
  qed
qed

locale executions_sc_hb =
  executions_base  P
  for  :: "('addr, 'thread_id) execution set"
  and P :: "'m prog" +
  assumes ℰ_new_actions_for_fun:
  " E  ; a  new_actions_for P E adal; a'  new_actions_for P E adal   a = a'"
  and ℰ_ex_new_action:
  " E  ; ra  read_actions E; adal  action_loc P E ra; non_speculative P (λ_. {}) (ltake (enat ra) (lmap snd E)) 
   wa. wa  new_actions_for P E adal  wa < ra"
begin

lemma ℰ_new_same_addr_singleton:
  assumes E: "E  "
  shows "a. new_actions_for P E adal  {a}"
by(blast dest: ℰ_new_actions_for_fun[OF E])

lemma new_action_before_read:
  assumes E: "E  "
  and ra: "ra  read_actions E"
  and adal: "adal  action_loc P E ra"
  and new: "wa  new_actions_for P E adal"
  and sc: "non_speculative P (λ_. {}) (ltake (enat ra) (lmap snd E))"
  shows "wa < ra"
using ℰ_new_same_addr_singleton[OF E, of adal] ℰ_ex_new_action[OF E ra adal sc] new
by auto

lemma most_recent_write_exists:
  assumes E: "E  "
  and ra: "ra  read_actions E"
  and sc: "non_speculative P (λ_. {}) (ltake (enat ra) (lmap snd E))"
  shows "wa. P,E  ra ↝mrw wa"
proof -
  from ra obtain ad al where
    adal: "(ad, al)  action_loc P E ra"
    by(rule read_action_action_locE)

  define Q where "Q = {a. a  write_actions E  (ad, al)  action_loc P E a  E  a ≤a ra}"
  let ?A = "new_actions_for P E (ad, al)"
  let ?B = "{a. a  actions E  (v'. action_obs E a = NormalAction (WriteMem ad al v'))  a  ra}"

  have "Q  ?A  ?B" unfolding Q_def
    by(auto elim!: write_actions.cases action_loc_aux_cases simp add: new_actions_for_def elim: action_orderE)
  moreover from ℰ_new_same_addr_singleton[OF E, of "(ad, al)"]
  have "finite ?A" by(blast intro: finite_subset)
  moreover have "finite ?B" by auto
  ultimately have finQ: "finite Q" 
    by(blast intro: finite_subset)

  from ℰ_ex_new_action[OF E ra adal sc] ra obtain wa 
    where wa: "wa  Q" unfolding Q_def
    by(fastforce elim!: new_actionsE is_new_action.cases read_actions.cases intro: write_actionsI action_orderI)
   
  define wa' where "wa' = Max_torder (action_order E) Q"

  from wa have "Q  {}" "Q  actions E" by(auto simp add: Q_def)
  with finQ have "wa'  Q" unfolding wa'_def
    by(rule Max_torder_in_set[OF torder_action_order])
  hence "E  wa' ≤a ra" "wa'  write_actions E"
    and "(ad, al)  action_loc P E wa'" by(simp_all add: Q_def)
  with ra adal have "P,E  ra ↝mrw wa'"
  proof
    fix wa''
    assume wa'': "wa''  write_actions E" "(ad, al)  action_loc P E wa''"
    from wa''  write_actions E ra
    have "ra  wa''" by(auto dest: read_actions_not_write_actions)
    show "E  wa'' ≤a wa'  E  ra ≤a wa''"
    proof(rule disjCI)
      assume "¬ E  ra ≤a wa''"
      with total_onPD[OF total_action_order, of ra E wa''] 
        ra  wa'' ra  read_actions E wa''  write_actions E
      have "E  wa'' ≤a ra" by simp
      with wa'' have "wa''  Q" by(simp add: Q_def)
      with finQ show "E  wa'' ≤a wa'"
        using Q  actions E unfolding wa'_def
        by(rule Max_torder_above[OF torder_action_order])
    qed
  qed
  thus ?thesis ..
qed

lemma mrw_before:
  assumes E: "E  "
  and mrw: "P,E  r ↝mrw w"
  and sc: "non_speculative P (λ_. {}) (ltake (enat r) (lmap snd E))"
  shows "w < r"
using mrw read_actions_not_write_actions[of r E]
apply cases
apply(erule action_orderE)
 apply(erule (1) new_action_before_read[OF E])
  apply(simp add: new_actions_for_def)
 apply(rule sc)
apply(cases "w = r")
apply auto
done

lemma sequentially_consistent_most_recent_write_for:
  assumes E: "E  "
  and sc: "non_speculative P (λ_. {}) (lmap snd E)"
  shows "sequentially_consistent P (E, λr. THE w. P,E  r ↝mrw w)"
proof(rule sequentially_consistentI)
  fix r
  assume r: "r  read_actions E"
  from sc have sc': "non_speculative P (λ_. {}) (ltake (enat r) (lmap snd E))"
    by(rule non_speculative_ltake)
  from most_recent_write_exists[OF E r this]
  obtain w where "P,E  r ↝mrw w" ..
  thus "P,E  r ↝mrw THE w. P,E  r ↝mrw w"
    by(simp add: THE_most_recent_writeI)
qed

end

locale jmm_multithreaded = multithreaded_base +
  constrains final :: "'x  bool" 
  and r :: "('l, 'thread_id, 'x, 'm, 'w, ('addr, 'thread_id) obs_event action) semantics" 
  and convert_RA :: "'l released_locks  ('addr, 'thread_id) obs_event action list" 
  fixes P :: "'md prog"

end

Theory SC_Completion

(*  Title:      JinjaThreads/MM/SC_Completion.thy
    Author:     Andreas Lochbihler
*)

section ‹Sequentially consistent completion of executions in the JMM›

theory SC_Completion 
imports
  Non_Speculative
begin

subsection ‹Most recently written values›

fun mrw_value :: 
  "'m prog  (('addr × addr_loc)  ('addr val × bool))  ('addr, 'thread_id) obs_event action
   (('addr × addr_loc)  ('addr val × bool))"
where
  "mrw_value P vs (NormalAction (WriteMem ad al v)) = vs((ad, al)  (v, True))"
| "mrw_value P vs (NormalAction (NewHeapElem ad hT)) =
   (λ(ad', al). if ad = ad'  al  addr_locs P hT  (case vs (ad, al) of None  True | Some (v, b)  ¬ b)
                then Some (addr_loc_default P hT al, False)
                else vs (ad', al))"
| "mrw_value P vs _ = vs"

lemma mrw_value_cases:
  obtains ad al v where "x = NormalAction (WriteMem ad al v)"
  | ad hT where "x = NormalAction (NewHeapElem ad hT)"
  | ad M vs v where "x = NormalAction (ExternalCall ad M vs v)"
  | ad al v where "x = NormalAction (ReadMem ad al v)"
  | t where "x = NormalAction (ThreadStart t)"
  | t where "x = NormalAction (ThreadJoin t)"
  | ad where "x = NormalAction (SyncLock ad)"
  | ad where "x = NormalAction (SyncUnlock ad)"
  | t where "x = NormalAction (ObsInterrupt t)"
  | t where "x = NormalAction (ObsInterrupted t)"
  | "x = InitialThreadAction"
  | "x = ThreadFinishAction"
by pat_completeness

abbreviation mrw_values ::
  "'m prog  (('addr × addr_loc)  ('addr val × bool))  ('addr, 'thread_id) obs_event action list
   (('addr × addr_loc)  ('addr val × bool))"
where "mrw_values P  foldl (mrw_value P)"

lemma mrw_values_eq_SomeD:
  assumes mrw: "mrw_values P vs0 obs (ad, al) = (v, b)"
  and "vs0 (ad, al) = (v, b)  wa. wa  set obs  is_write_action wa  (ad, al)  action_loc_aux P wa  (b  ¬ is_new_action wa)"
  shows "obs' wa obs''. obs = obs' @ wa # obs''  is_write_action wa  (ad, al)  action_loc_aux P wa 
            value_written_aux P wa al = v  (is_new_action wa  ¬ b) 
            (obset obs''. is_write_action ob  (ad, al)  action_loc_aux P ob  is_new_action ob  b)"
  (is "?concl obs")
using assms
proof(induct obs rule: rev_induct)
  case Nil thus ?case by simp
next
  case (snoc ob obs)
  note mrw = ‹mrw_values P vs0 (obs @ [ob]) (ad, al) = (v, b)
  show ?case
  proof(cases "is_write_action ob  (ad, al)  action_loc_aux P ob  (is_new_action ob  ¬ b)")
    case True thus ?thesis using mrw
      by(fastforce elim!: is_write_action.cases intro: action_loc_aux_intros split: if_split_asm)
  next
    case False
    with mrw have "mrw_values P vs0 obs (ad, al) = (v, b)"
      by(cases "ob" rule: mrw_value_cases)(auto split: if_split_asm simp add: addr_locs_def split: htype.split_asm)
    moreover
    { assume "vs0 (ad, al) = (v, b)"
      hence "wa. wa  set (obs @ [ob])  is_write_action wa  (ad, al)  action_loc_aux P wa  (b  ¬ is_new_action wa)"
        by(rule snoc)
      with False have "wa. wa  set obs  is_write_action wa  (ad, al)  action_loc_aux P wa  (b  ¬ is_new_action wa)"
        by auto }
    ultimately have "?concl obs" by(rule snoc)
    thus ?thesis using False mrw by fastforce
  qed
qed

lemma mrw_values_WriteMemD:
  assumes "NormalAction (WriteMem ad al v')  set obs"
  shows "v. mrw_values P vs0 obs (ad, al) = Some (v, True)"
using assms
apply(induct obs rule: rev_induct)
 apply simp
apply clarsimp
apply(erule disjE)
 apply clarsimp
apply clarsimp
apply(case_tac x rule: mrw_value_cases)
apply simp_all
done

lemma mrw_values_new_actionD:
  assumes "w  set obs" "is_new_action w" "adal  action_loc_aux P w"
  shows "v b. mrw_values P vs0 obs adal = Some (v, b)"
using assms
apply(induct obs rule: rev_induct)
 apply simp
apply clarsimp
apply(erule disjE)
 apply(fastforce simp add: split_beta elim!: action_loc_aux_cases is_new_action.cases)
apply clarsimp
apply(rename_tac w' obs' v b)
apply(case_tac w' rule: mrw_value_cases)
apply(auto simp add: split_beta)
done

lemma mrw_value_dom_mono:
  "dom vs  dom (mrw_value P vs ob)"
by(cases ob rule: mrw_value_cases) auto

lemma mrw_values_dom_mono:
  "dom vs  dom (mrw_values P vs obs)"
by(induct obs arbitrary: vs)(auto intro: subset_trans[OF mrw_value_dom_mono] del: subsetI)

lemma mrw_values_eq_NoneD:
  assumes "mrw_values P vs0 obs adal = None"
  and "w  set obs" and "is_write_action w" and "adal  action_loc_aux P w"
  shows False
using assms
apply -
apply(erule is_write_action.cases)
apply(fastforce dest: mrw_values_WriteMemD[where ?vs0.0=vs0 and P=P] mrw_values_new_actionD[where ?vs0.0=vs0] elim: action_loc_aux_cases)+
done

lemma mrw_values_mrw:
  assumes mrw: "mrw_values P vs0 (map snd obs) (ad, al) = (v, b)"
  and initial: "vs0 (ad, al) = (v, b)  wa. wa  set (map snd obs)  is_write_action wa  (ad, al)  action_loc_aux P wa  (b  ¬ is_new_action wa)"
  shows "i. i < length obs  P,llist_of (obs @ [(t, NormalAction (ReadMem ad al v))])  length obs ↝mrw i  value_written P (llist_of obs) i (ad, al) = v"
proof -
  from mrw_values_eq_SomeD[OF mrw initial]
  obtain obs' wa obs'' where obs: "map snd obs = obs' @ wa # obs''"
    and wa: "is_write_action wa"
    and adal: "(ad, al)  action_loc_aux P wa"
    and written: "value_written_aux P wa al = v"
    and new: "is_new_action wa  ¬ b"
    and last: "ob.  ob  set obs''; is_write_action ob; (ad, al)  action_loc_aux P ob   is_new_action ob  b"
    by blast
  let ?i = "length obs'"
  let ?E = "llist_of (obs @ [(t, NormalAction (ReadMem ad al v))])"

  from obs have len: "length (map snd obs) = Suc (length obs') + length obs''" by simp
  hence "?i < length obs" by simp
  moreover
  hence obs_i: "action_obs ?E ?i = wa" using len obs
    by(auto simp add: action_obs_def map_eq_append_conv)

  have "P,?E  length obs ↝mrw ?i"
  proof(rule most_recent_write_for.intros)
    show "length obs  read_actions ?E"
      by(auto intro: read_actions.intros simp add: actions_def action_obs_def)
    show "(ad, al)  action_loc P ?E (length obs)"
      by(simp add: action_obs_def lnth_llist_of)
    show "?E  length obs' ≤a length obs" using len
      by-(rule action_orderI, auto simp add: actions_def action_obs_def nth_append)
    show "?i  write_actions ?E" using len obs wa
      by-(rule write_actions.intros, auto simp add: actions_def action_obs_def nth_append map_eq_append_conv)
    show "(ad, al)  action_loc P ?E ?i" using obs_i adal by simp

    fix wa'
    assume wa': "wa'  write_actions ?E"
      and adal': "(ad, al)  action_loc P ?E wa'"
    from wa' ?i  write_actions ?E
    have "wa'  actions ?E" "?i  actions ?E" by simp_all
    hence "?E  wa' ≤a ?i"
    proof(rule action_orderI)
      assume new_wa': "is_new_action (action_obs ?E wa')"
        and new_i: "is_new_action (action_obs ?E ?i)"
      from new_i obs_i new have b: "¬ b" by simp

      show "wa'  ?i"
      proof(rule ccontr)
        assume "¬ ?thesis"
        hence "?i < wa'" by simp
        hence "snd (obs ! wa')  set obs''" using obs wa' unfolding in_set_conv_nth
          by -(rule exI[where x="wa' - Suc (length obs')"], auto elim!: write_actions.cases actionsE simp add: action_obs_def lnth_llist_of actions_def nth_append map_eq_append_conv nth_Cons' split: if_split_asm)
        moreover from wa' have "is_write_action (snd (obs ! wa'))"
          by cases(auto simp add: action_obs_def nth_append actions_def split: if_split_asm)
        moreover from adal' wa' have "(ad, al)  action_loc_aux P (snd (obs ! wa'))"
          by(auto simp add: action_obs_def nth_append nth_Cons' actions_def split: if_split_asm elim!: write_actions.cases)
        ultimately show False using last[of "snd (obs ! wa')"] b by simp
      qed
    next
      assume new_wa': "¬ is_new_action (action_obs ?E wa')"
      with wa' adal' obtain v' where "NormalAction (WriteMem ad al v')  set (map snd obs)"
        unfolding in_set_conv_nth
        by (fastforce elim!: write_actions.cases is_write_action.cases simp add: action_obs_def actions_def nth_append split: if_split_asm intro!: exI[where x=wa'])
      from mrw_values_WriteMemD[OF this, of P vs0] mrw have b by simp
      with new obs_i have "¬ is_new_action (action_obs ?E ?i)" by simp
      moreover
      have "wa'  ?i"
      proof(rule ccontr)
        assume "¬ ?thesis"
        hence "?i < wa'" by simp
        hence "snd (obs ! wa')  set obs''" using obs wa' unfolding in_set_conv_nth
          by -(rule exI[where x="wa' - Suc (length obs')"], auto elim!: write_actions.cases actionsE simp add: action_obs_def lnth_llist_of actions_def nth_append map_eq_append_conv nth_Cons' split: if_split_asm)
        moreover from wa' have "is_write_action (snd (obs ! wa'))"
          by cases(auto simp add: action_obs_def nth_append actions_def split: if_split_asm)
        moreover from adal' wa' have "(ad, al)  action_loc_aux P (snd (obs ! wa'))"
          by(auto simp add: action_obs_def nth_append nth_Cons' actions_def split: if_split_asm elim!: write_actions.cases)
        ultimately have "is_new_action (snd (obs ! wa'))" using last[of "snd (obs ! wa')"] by simp
        moreover from new_wa' wa' have "¬ is_new_action (snd (obs ! wa'))"
          by(auto elim!: write_actions.cases simp add: action_obs_def nth_append actions_def split: if_split_asm)
        ultimately show False by contradiction
      qed
      ultimately
      show "¬ is_new_action (action_obs ?E ?i)  wa'  ?i" by blast
    qed
    thus "?E  wa' ≤a ?i  ?E  length obs ≤a wa'" ..
  qed
  moreover from written ?i < length obs obs_i
  have "value_written P (llist_of obs) ?i (ad, al) = v"
    by(simp add: value_written_def action_obs_def nth_append)
  ultimately show ?thesis by blast
qed

lemma mrw_values_no_write_unchanged:
  assumes no_write: "w.  w  set obs; is_write_action w; adal  action_loc_aux P w 
   case vs adal of None  False | Some (v, b)  b  is_new_action w"
  shows "mrw_values P vs obs adal = vs adal"
using assms
proof(induct obs arbitrary: vs)
  case Nil show ?case by simp
next
  case (Cons ob obs)
  from Cons.prems[of ob]
  have "mrw_value P vs ob adal = vs adal"
    apply(cases adal)
    apply(cases ob rule: mrw_value_cases, fastforce+)
    apply(auto simp add: addr_locs_def split: htype.split_asm)
    apply blast+
    done
  moreover
  have "mrw_values P (mrw_value P vs ob) obs adal = mrw_value P vs ob adal"
  proof(rule Cons.hyps)
    fix w
    assume "w  set obs" "is_write_action w" "adal  action_loc_aux P w"
    with Cons.prems[of w] ‹mrw_value P vs ob adal = vs adal
    show "case mrw_value P vs ob adal of None  False | (v, b)  b  is_new_action w" by simp
  qed
  ultimately show ?case by simp
qed

subsection ‹Coinductive version of sequentially consistent prefixes›

coinductive ta_seq_consist :: 
  "'m prog  ('addr × addr_loc  'addr val × bool)  ('addr, 'thread_id) obs_event action llist  bool"
for P :: "'m prog" 
where
  LNil: "ta_seq_consist P vs LNil"
| LCons:
  " case ob of NormalAction (ReadMem ad al v)  b. vs (ad, al) = (v, b) | _  True;
     ta_seq_consist P (mrw_value P vs ob) obs  
   ta_seq_consist P vs (LCons ob obs)"

inductive_simps ta_seq_consist_simps [simp]:
  "ta_seq_consist P vs LNil"
  "ta_seq_consist P vs (LCons ob obs)"

lemma ta_seq_consist_lappend:
  assumes "lfinite obs"
  shows "ta_seq_consist P vs (lappend obs obs') 
         ta_seq_consist P vs obs  ta_seq_consist P (mrw_values P vs (list_of obs)) obs'"
  (is "?concl vs obs")
using assms
proof(induct arbitrary: vs)
  case lfinite_LNil thus ?case by simp
next
  case (lfinite_LConsI obs ob)
  have "?concl (mrw_value P vs ob) obs" by fact
  thus ?case using ‹lfinite obs by(simp split: action.split add: list_of_LCons)
qed

lemma
  assumes "ta_seq_consist P vs obs"
  shows ta_seq_consist_ltake: "ta_seq_consist P vs (ltake n obs)" (is ?thesis1)
  and ta_seq_consist_ldrop: "ta_seq_consist P (mrw_values P vs (list_of (ltake n obs))) (ldrop n obs)" (is ?thesis2)
proof -
  note assms
  also have "obs = lappend (ltake n obs) (ldrop n obs)" by(simp add: lappend_ltake_ldrop)
  finally have "?thesis1  ?thesis2"
    by(cases n)(simp_all add: ta_seq_consist_lappend del: lappend_ltake_enat_ldropn)
  thus ?thesis1 ?thesis2 by blast+
qed

lemma ta_seq_consist_coinduct_append [consumes 1, case_names ta_seq_consist, case_conclusion ta_seq_consist LNil lappend]:
  assumes major: "X vs obs"
  and step: "vs obs. X vs obs 
     obs = LNil 
       (obs' obs''. obs = lappend obs' obs''  obs'  LNil  ta_seq_consist P vs obs' 
                    (lfinite obs'  (X (mrw_values P vs (list_of obs')) obs''  
                                       ta_seq_consist P (mrw_values P vs (list_of obs')) obs'')))"
    (is "vs obs. _  _  ?step vs obs")
  shows "ta_seq_consist P vs obs"
proof -
  from major
  have "obs' obs''. obs = lappend (llist_of obs') obs''  ta_seq_consist P vs (llist_of obs')  
                     X (mrw_values P vs obs') obs''"
    by(auto intro: exI[where x="[]"])
  thus ?thesis
  proof(coinduct)
    case (ta_seq_consist vs obs)
    then obtain obs' obs'' 
      where obs: "obs = lappend (llist_of obs') obs''"
      and sc_obs': "ta_seq_consist P vs (llist_of obs')"
      and X: "X (mrw_values P vs obs') obs''" by blast

    show ?case
    proof(cases obs')
      case Nil
      with X have "X vs obs''" by simp
      from step[OF this] show ?thesis
      proof
        assume "obs'' = LNil" 
        with Nil obs show ?thesis by simp
      next
        assume "?step vs obs''"
        then obtain obs''' obs'''' 
          where obs'': "obs'' = lappend obs''' obs''''" and "obs'''  LNil"
          and sc_obs''': "ta_seq_consist P vs obs'''" 
          and fin: "lfinite obs'''  X (mrw_values P vs (list_of obs''')) obs'''' 
                                      ta_seq_consist P (mrw_values P vs (list_of obs''')) obs''''"
          by blast
        from obs'''  LNil› obtain ob obs''''' where obs''': "obs''' = LCons ob obs'''''"
          unfolding neq_LNil_conv by blast
        with Nil obs'' obs have concl1: "obs = LCons ob (lappend obs''''' obs'''')" by simp
        have concl2: "case ob of NormalAction (ReadMem ad al v)  b. vs (ad, al) = (v, b) | _  True"
          using sc_obs''' obs''' by simp

        show ?thesis
        proof(cases "lfinite obs'''")
          case False
          hence "lappend obs''''' obs'''' = obs'''''" using obs''' by(simp add: lappend_inf)
          hence "ta_seq_consist P (mrw_value P vs ob) (lappend obs''''' obs'''')" 
            using sc_obs''' obs''' by simp
          with concl1 concl2 have ?LCons by blast
          thus ?thesis by simp
        next
          case True
          with obs''' obtain obs'''''' where obs''''': "obs''''' = llist_of obs''''''"
            by simp(auto simp add: lfinite_eq_range_llist_of)
          from fin[OF True] have "?LCons"
          proof
            assume X: "X (mrw_values P vs (list_of obs''')) obs''''"
            hence "X (mrw_values P (mrw_value P vs ob) obs'''''') obs''''"
              using obs''''' obs''' by simp
            moreover from obs'''''
            have "lappend obs''''' obs'''' = lappend (llist_of obs'''''') obs''''" by simp
            moreover have "ta_seq_consist P (mrw_value P vs ob) (llist_of obs'''''')" 
              using sc_obs''' obs''' obs''''' by simp
            ultimately show ?thesis using concl1 concl2 by blast
          next
            assume "ta_seq_consist P (mrw_values P vs (list_of obs''')) obs''''"
            with sc_obs''' obs''''' obs'''
            have "ta_seq_consist P (mrw_value P vs ob) (lappend obs''''' obs'''')"
              by(simp add: ta_seq_consist_lappend)
            with concl1 concl2 show ?thesis by blast
          qed
          thus ?thesis by simp
        qed
      qed
    next
      case (Cons ob obs''')
      hence "obs = LCons ob (lappend (llist_of obs''') obs'')"
        using obs by simp
      moreover from sc_obs' Cons 
      have "case ob of NormalAction (ReadMem ad al v)  b. vs (ad, al) = (v, b) | _  True"
        and "ta_seq_consist P (mrw_value P vs ob) (llist_of obs''')" by simp_all
      moreover from X Cons have "X (mrw_values P (mrw_value P vs ob) obs''') obs''" by simp
      ultimately show ?thesis by blast
    qed
  qed
qed

lemma ta_seq_consist_coinduct_append_wf
  [consumes 2, case_names ta_seq_consist, case_conclusion ta_seq_consist LNil lappend]:
  assumes major: "X vs obs a"
  and wf: "wf R"
  and step: "vs obs a. X vs obs a
     obs = LNil 
       (obs' obs'' a'. obs = lappend obs' obs''  ta_seq_consist P vs obs'  (obs' = LNil  (a', a)  R) 
                        (lfinite obs'  X (mrw_values P vs (list_of obs')) obs'' a' 
                                          ta_seq_consist P (mrw_values P vs (list_of obs')) obs''))"
    (is "vs obs a. _  _  ?step vs obs a")
  shows "ta_seq_consist P vs obs"
proof -
  { fix vs obs a
    assume "X vs obs a"
    with wf
    have "obs = LNil  (obs' obs''. obs = lappend obs' obs''  obs'  LNil  ta_seq_consist P vs obs' 
          (lfinite obs'  (a. X (mrw_values P vs (list_of obs')) obs'' a)  
                            ta_seq_consist P (mrw_values P vs (list_of obs')) obs''))"
      (is "_  ?step_concl vs obs")
    proof(induct a arbitrary: vs obs rule: wf_induct[consumes 1, case_names wf])
      case (wf a)
      note IH = wf.hyps[rule_format]
      from step[OF X vs obs a]
      show ?case
      proof
        assume "obs = LNil" thus ?thesis ..
      next
        assume "?step vs obs a"
        then obtain obs' obs'' a'
          where obs: "obs = lappend obs' obs''"
          and sc_obs': "ta_seq_consist P vs obs'"
          and decr: "obs' = LNil  (a', a)  R"
          and fin: "lfinite obs'  
                    X (mrw_values P vs (list_of obs')) obs'' a' 
                    ta_seq_consist P (mrw_values P vs (list_of obs')) obs''"
          by blast
        show ?case
        proof(cases "obs' = LNil")
          case True
          hence "lfinite obs'" by simp
          from fin[OF this] show ?thesis
          proof
            assume X: "X (mrw_values P vs (list_of obs')) obs'' a'"
            from True have "(a', a)  R" by(rule decr)
            from IH[OF this X] show ?thesis
            proof
              assume "obs'' = LNil"
              with True obs have "obs = LNil" by simp
              thus ?thesis ..
            next
              assume "?step_concl (mrw_values P vs (list_of obs')) obs''"
              hence "?step_concl vs obs" using True obs by simp
              thus ?thesis ..
            qed
          next
            assume "ta_seq_consist P (mrw_values P vs (list_of obs')) obs''"
            thus ?thesis using obs True
              by cases(auto cong: action.case_cong obs_event.case_cong intro: exI[where x="LCons x LNil" for x])
          qed
        next
          case False
          with obs sc_obs' fin show ?thesis by auto
        qed
      qed
    qed }
  note step' = this

  from major show ?thesis
  proof(coinduction arbitrary: vs obs a rule: ta_seq_consist_coinduct_append)
    case (ta_seq_consist vs obs a)
    thus ?case by simp(rule step')
  qed
qed

lemma ta_seq_consist_nthI:
  "(i ad al v.  enat i < llength obs; lnth obs i = NormalAction (ReadMem ad al v);
      ta_seq_consist P vs (ltake (enat i) obs)  
     b. mrw_values P vs (list_of (ltake (enat i) obs)) (ad, al) = (v, b))
   ta_seq_consist P vs obs"
proof(coinduction arbitrary: vs obs)
  case (ta_seq_consist vs obs)
  hence nth:
    "i ad al v.  enat i < llength obs; lnth obs i = NormalAction (ReadMem ad al v); 
                   ta_seq_consist P vs (ltake (enat i) obs)  
     b. mrw_values P vs (list_of (ltake (enat i) obs)) (ad, al) = (v, b)" by blast
  show ?case
  proof(cases obs)
    case LNil thus ?thesis by simp
  next
    case (LCons ob obs')
    { fix ad al v
      assume "ob = NormalAction (ReadMem ad al v)"
      with nth[of 0 ad al v] LCons
      have "b. vs (ad, al) = (v, b)"
        by(simp add: zero_enat_def[symmetric]) }
    note base = this
    moreover { 
      fix i ad al v
      assume "enat i < llength obs'" "lnth obs' i = NormalAction (ReadMem ad al v)"
        and "ta_seq_consist P (mrw_value P vs ob) (ltake (enat i) obs')"
      with LCons nth[of "Suc i" ad al v] base
      have "b. mrw_values P (mrw_value P vs ob) (list_of (ltake (enat i) obs')) (ad, al) = (v, b)"
        by(clarsimp simp add: eSuc_enat[symmetric] split: obs_event.split action.split) }
    ultimately have ?LCons using LCons by(simp split: action.split obs_event.split)
    thus ?thesis ..
  qed
qed

lemma ta_seq_consist_into_non_speculative:
  " ta_seq_consist P vs obs; adal. set_option (vs adal)  vs' adal × UNIV 
   non_speculative P vs' obs"
proof(coinduction arbitrary: vs' obs vs)
  case (non_speculative vs' obs vs)
  thus ?case
    apply cases
    apply(auto split: action.split_asm obs_event.split_asm)
    apply(rule exI, erule conjI, auto)+
    done
qed

lemma llist_of_list_of_append:
  "lfinite xs  llist_of (list_of xs @ ys) = lappend xs (llist_of ys)"
unfolding lfinite_eq_range_llist_of by(clarsimp simp add: lappend_llist_of_llist_of)

lemma ta_seq_consist_most_recent_write_for:
  assumes sc: "ta_seq_consist P Map.empty (lmap snd E)"
  and read: "r  read_actions E"
  and new_actions_for_fun: "adal a a'.  a  new_actions_for P E adal; a'  new_actions_for P E adal   a = a'"
  shows "i. P,E  r ↝mrw i  i < r"
proof -
  from read obtain t v ad al 
    where nth_r: "lnth E r = (t, NormalAction (ReadMem ad al v))"
    and r: "enat r < llength E"
    by(cases)(cases "lnth E r", auto simp add: action_obs_def actions_def)
  from nth_r r
  have E_unfold: "E = lappend (ltake (enat r) E) (LCons (t, NormalAction (ReadMem ad al v)) (ldropn (Suc r) E))"
    by (metis lappend_ltake_enat_ldropn ldropn_Suc_conv_ldropn)
  from sc obtain b where sc': "ta_seq_consist P Map.empty (ltake (enat r) (lmap snd E))"
    and mrw': "mrw_values P Map.empty (map snd (list_of (ltake (enat r) E))) (ad, al) = (v, b)"
    by(subst (asm) (3) E_unfold)(auto simp add: ta_seq_consist_lappend lmap_lappend_distrib)
  
  from mrw_values_mrw[OF mrw', of t] r
  obtain E' w' 
    where E': "E' = llist_of (list_of (ltake (enat r) E) @ [(t, NormalAction (ReadMem ad al v))])"
    and v: "v = value_written P (ltake (enat r) E) w' (ad, al)"
    and mrw'': "P,E'  r ↝mrw w'"
    and w': "w' < r" by(fastforce simp add: length_list_of_conv_the_enat min_def split: if_split_asm)

  from E' r have sim: "ltake (enat (Suc r)) E' [≈] ltake (enat (Suc r)) E"
    by(subst E_unfold)(simp add: ltake_lappend llist_of_list_of_append min_def, auto simp add: eSuc_enat[symmetric] zero_enat_def[symmetric] eq_into_sim_actions)
  from nth_r have adal_r: "(ad, al)  action_loc P E r" by(simp add: action_obs_def)
  from E' r have nth_r': "lnth E' r = (t, NormalAction (ReadMem ad al v))"
    by(auto simp add: nth_append length_list_of_conv_the_enat min_def)
  with mrw'' w' r adal_r obtain "E  w' ≤a r" "w'  write_actions E" "(ad, al)  action_loc P E w'"
    by cases(fastforce simp add: action_obs_def action_loc_change_prefix[OF sim[symmetric], simplified action_obs_def] intro: action_order_change_prefix[OF _ sim] write_actions_change_prefix[OF _ sim])
  
  with read adal_r have "P,E  r ↝mrw w'"
  proof(rule most_recent_write_for.intros)
    fix wa'
    assume write': "wa'  write_actions E"
      and adal_wa': "(ad, al)  action_loc P E wa'"
    show "E  wa' ≤a w'  E  r ≤a wa'"
    proof(cases "r  wa'")
      assume "r  wa'"
      show ?thesis
      proof(cases "is_new_action (action_obs E wa')")
        case False
        with r  wa' have "E  r ≤a wa'" using read write'
          by(auto simp add: action_order_def elim!: read_actions.cases)
        thus ?thesis ..
      next
        case True
        with write' adal_wa' have "wa'  new_actions_for P E (ad, al)"
          by(simp add: new_actions_for_def)
        hence "w'  new_actions_for P E (ad, al)" using r w' r  wa'
          by(auto dest: new_actions_for_fun)
        with w'  write_actions E (ad, al)  action_loc P E w'
        have "¬ is_new_action (action_obs E w')" by(simp add: new_actions_for_def)
        with write' True w'  write_actions E have "E  wa' ≤a w'" by(simp add: action_order_def)
        thus ?thesis ..
      qed
    next
      assume "¬ r  wa'"
      hence "wa' < r" by simp
      with write' adal_wa'
      have "wa'  write_actions E'" "(ad, al)  action_loc P E' wa'"
        by(auto intro: write_actions_change_prefix[OF _ sim[symmetric]] simp add: action_loc_change_prefix[OF sim])
      from most_recent_write_recent[OF mrw'' _ this] nth_r'
      have "E'  wa' ≤a w'  E'  r ≤a wa'" by(simp add: action_obs_def)
      thus ?thesis using wa' < r w'
        by(auto 4 3 del: disjCI intro: disjI1 disjI2 action_order_change_prefix[OF _ sim])
    qed
  qed
  with w' show ?thesis by blast
qed

lemma ta_seq_consist_mrw_before:
  assumes sc: "ta_seq_consist P Map.empty (lmap snd E)"
  and new_actions_for_fun: "adal a a'.  a  new_actions_for P E adal; a'  new_actions_for P E adal   a = a'"
  and mrw: "P,E  r ↝mrw w"
  shows "w < r"
proof -
  from mrw have "r  read_actions E" by cases
  with sc new_actions_for_fun obtain w' where "P,E  r ↝mrw w'" "w' < r"
    by(auto dest: ta_seq_consist_most_recent_write_for)
  with mrw show ?thesis by(auto dest: most_recent_write_for_fun)
qed

lemma ta_seq_consist_imp_sequentially_consistent:
  assumes tsa_ok: "thread_start_actions_ok E"
  and new_actions_for_fun: "adal a a'.  a  new_actions_for P E adal; a'  new_actions_for P E adal   a = a'"
  and seq: "ta_seq_consist P Map.empty (lmap snd E)"
  shows "ws. sequentially_consistent P (E, ws)  P  (E, ws) "
proof(intro exI conjI)
  define ws where "ws i = (THE w. P,E  i ↝mrw w)" for i
  from seq have ns: "non_speculative P (λ_. {}) (lmap snd E)"
    by(rule ta_seq_consist_into_non_speculative) simp
  show "sequentially_consistent P (E, ws)" unfolding ws_def
  proof(rule sequentially_consistentI)
    fix r
    assume "r  read_actions E"
    with seq new_actions_for_fun
    obtain w where "P,E  r ↝mrw w" by(auto dest: ta_seq_consist_most_recent_write_for)
    thus "P,E  r ↝mrw THE w. P,E  r ↝mrw w" by(simp add: THE_most_recent_writeI)
  qed

  show "P  (E, ws) "
  proof(rule wf_execI)
    show "is_write_seen P E ws"
    proof(rule is_write_seenI)
      fix a ad al v
      assume a: "a  read_actions E"
        and adal: "action_obs E a = NormalAction (ReadMem ad al v)"
      from ns have seq': "non_speculative P (λ_. {}) (ltake (enat a) (lmap snd E))" by(rule non_speculative_ltake)
      from seq a seq new_actions_for_fun
      obtain w where mrw: "P,E  a ↝mrw w" 
        and "w < a" by(auto dest: ta_seq_consist_most_recent_write_for)
      hence w: "ws a = w" by(simp add: ws_def THE_most_recent_writeI)
      with mrw adal

      show "ws a  write_actions E"
        and "(ad, al)  action_loc P E (ws a)"
        and "¬ P,E  a ≤hb ws a"
        by(fastforce elim!: most_recent_write_for.cases dest: happens_before_into_action_order antisymPD[OF antisym_action_order] read_actions_not_write_actions)+

      let ?between = "ltake (enat (a - Suc w)) (ldropn (Suc w) E)"
      let ?prefix = "ltake (enat w) E"
      let ?vs_prefix = "mrw_values P Map.empty (map snd (list_of ?prefix))"

      { fix v'
        assume new: "is_new_action (action_obs E w)"
          and vs': "?vs_prefix (ad, al) = (v', True)"
        from mrw_values_eq_SomeD[OF vs']
        obtain obs' wa obs'' where split: "map snd (list_of ?prefix) = obs' @ wa # obs''"
          and wa: "is_write_action wa"
          and adal': "(ad, al)  action_loc_aux P wa"
          and new_wa: "¬ is_new_action wa" by blast
        from split have "length (map snd (list_of ?prefix)) = Suc (length obs' + length obs'')" by simp
        hence len_prefix: "llength ?prefix = enat " by(simp add: length_list_of_conv_the_enat min_enat1_conv_enat)
        with split have "nth (map snd (list_of ?prefix)) (length obs') = wa"
          and "enat (length obs') < llength ?prefix" by simp_all
        hence "snd (lnth ?prefix (length obs')) = wa" by(simp add: list_of_lmap[symmetric] del: list_of_lmap)
        hence wa': "action_obs E (length obs') = wa" and "enat (length obs') < llength E"
          using ‹enat (length obs') < llength ?prefix by(auto simp add: action_obs_def lnth_ltake)
        with wa have "length obs'  write_actions E" by(auto intro: write_actions.intros simp add: actions_def)
        from most_recent_write_recent[OF mrw _ this, of "(ad, al)"] adal adal' wa'
        have "E  length obs' ≤a w  E  a ≤a length obs'" by simp
        hence False using new_wa new wa' adal len_prefix w < a
          by(auto elim!: action_orderE simp add: min_enat1_conv_enat split: enat.split_asm) 
      }
      hence mrw_value_w: "mrw_value P ?vs_prefix (snd (lnth E w)) (ad, al) =
                          (value_written P E w (ad, al), ¬ is_new_action (action_obs E w))"
        using ws a  write_actions E (ad, al)  action_loc P E (ws a) w
        by(cases "snd (lnth E w)" rule: mrw_value_cases)(fastforce elim: write_actions.cases simp add: value_written_def action_obs_def)+
      have "mrw_values P (mrw_value P ?vs_prefix (snd (lnth E w))) (list_of (lmap snd ?between)) (ad, al) = (value_written P E w (ad, al), ¬ is_new_action (action_obs E w))"
      proof(subst mrw_values_no_write_unchanged)
        fix wa
        assume "wa  set (list_of (lmap snd ?between))"
          and write_wa: "is_write_action wa"
          and adal_wa: "(ad, al)  action_loc_aux P wa"
        hence wa: "wa  lset (lmap snd ?between)" by simp
        from wa obtain i_wa where "wa = lnth (lmap snd ?between) i_wa"
          and i_wa: "enat i_wa < llength (lmap snd ?between)"
          unfolding lset_conv_lnth by blast
        moreover hence i_wa_len: "enat (Suc (w + i_wa)) < llength E" by(cases "llength E") auto
        ultimately have wa': "wa = action_obs E (Suc (w + i_wa))"
          by(simp_all add: lnth_ltake action_obs_def ac_simps)
        with write_wa i_wa_len have "Suc (w + i_wa)  write_actions E"
          by(auto intro: write_actions.intros simp add: actions_def)
        from most_recent_write_recent[OF mrw _ this, of "(ad, al)"] adal adal_wa wa'
        have "E  Suc (w + i_wa) ≤a w  E  a ≤a Suc (w + i_wa)" by(simp)
        hence "is_new_action wa  ¬ is_new_action (action_obs E w)"
          using adal i_wa wa' by(auto elim: action_orderE)
        thus "case (mrw_value P ?vs_prefix (snd (lnth E w)) (ad, al)) of None  False | Some (v, b)  b  is_new_action wa"
          unfolding mrw_value_w by simp
      qed(simp add: mrw_value_w)

      moreover

      from a have "a  actions E" by simp
      hence "enat a < llength E" by(rule actionsE)
      with w < a have "enat (a - Suc w) < llength E - enat (Suc w)"
        by(cases "llength E") simp_all
      hence "E = lappend (lappend ?prefix (LCons (lnth E w) ?between)) (LCons (lnth (ldropn (Suc w) E) (a - Suc w)) (ldropn (Suc (a - Suc w)) (ldropn (Suc w) E)))"
        using w < a ‹enat a < llength E unfolding lappend_assoc lappend_code
        apply(subst ldropn_Suc_conv_ldropn, simp)
        apply(subst lappend_ltake_enat_ldropn)
        apply(subst ldropn_Suc_conv_ldropn, simp add: less_trans[where y="enat a"])
        by simp
      hence E': "E = lappend (lappend ?prefix (LCons (lnth E w) ?between)) (LCons (lnth E a) (ldropn (Suc a) E))"
        using w < a ‹enat a < llength E by simp
      
      from seq have "ta_seq_consist P (mrw_values P Map.empty (list_of (lappend (lmap snd ?prefix) (LCons (snd (lnth E w)) (lmap snd ?between))))) (lmap snd (LCons (lnth E a) (ldropn (Suc a) E)))"
        by(subst (asm) E')(simp add: lmap_lappend_distrib ta_seq_consist_lappend)
      ultimately show "value_written P E (ws a) (ad, al) = v" using adal w
        by(clarsimp simp add: action_obs_def list_of_lappend list_of_LCons)

      (* assume "is_volatile P al" *)
      show "¬ P,E  a ≤so ws a" using w < a w adal by(auto elim!: action_orderE sync_orderE)

      fix a'
      assume a': "a'  write_actions E" "(ad, al)  action_loc P E a'"

      {
        presume "E  ws a ≤a a'" "E  a' ≤a a"
        with mrw adal a' have "a' = ws a" unfolding w
          by cases(fastforce dest: antisymPD[OF antisym_action_order] read_actions_not_write_actions elim!: meta_allE[where x=a'])
        thus "a' = ws a" "a' = ws a" by -
      next
        assume "P,E  ws a ≤hb a'" "P,E  a' ≤hb a"
        thus "E  ws a ≤a a'" "E  a' ≤a a" using a' by(blast intro: happens_before_into_action_order)+
      next
        assume "is_volatile P al" "P,E  ws a ≤so a'" "P,E  a' ≤so a"
        thus "E  ws a ≤a a'" "E  a' ≤a a" by(auto elim: sync_orderE)
      }
    qed
  qed(rule tsa_ok)
qed

subsection ‹Cut-and-update and sequentially consistent completion›

inductive foldl_list_all2 ::
  "('b  'c  'a  'a)  ('b  'c  'a  bool)  ('b  'c  'a  bool)  'b list  'c list  'a  bool"
for f and P and Q
where
  "foldl_list_all2 f P Q [] [] s"
| " Q x y s; P x y s  foldl_list_all2 f P Q xs ys (f x y s)   foldl_list_all2 f P Q (x # xs) (y # ys) s"

inductive_simps foldl_list_all2_simps [simp]:
  "foldl_list_all2 f P Q [] ys s"
  "foldl_list_all2 f P Q xs [] s"
  "foldl_list_all2 f P Q (x # xs) (y # ys) s"

inductive_simps foldl_list_all2_Cons1:
  "foldl_list_all2 f P Q (x # xs) ys s"

inductive_simps foldl_list_all2_Cons2:
  "foldl_list_all2 f P Q xs (y # ys) s"

definition eq_upto_seq_inconsist ::
  "'m prog  ('addr, 'thread_id) obs_event action list  ('addr, 'thread_id) obs_event action list
   ('addr × addr_loc  'addr val × bool)  bool"
where
  "eq_upto_seq_inconsist P =
   foldl_list_all2 (λob ob' vs. mrw_value P vs ob) 
                   (λob ob' vs. case ob of NormalAction (ReadMem ad al v)  b. vs (ad, al) = Some (v, b) | _  True)
                   (λob ob' vs. if (case ob of NormalAction (ReadMem ad al v)  b. vs (ad, al) = Some (v, b) | _  True) then ob = ob' else ob  ob')"

lemma eq_upto_seq_inconsist_simps:
  "eq_upto_seq_inconsist P [] obs' vs  obs' = []"
  "eq_upto_seq_inconsist P obs [] vs  obs = []"
  "eq_upto_seq_inconsist P (ob # obs) (ob' # obs') vs  
   (case ob of NormalAction (ReadMem ad al v)  
      if (b. vs (ad, al) = (v, b)) 
      then ob = ob'  eq_upto_seq_inconsist P obs obs' (mrw_value P vs ob) 
      else ob  ob'
    | _  ob = ob'  eq_upto_seq_inconsist P obs obs' (mrw_value P vs ob))"
by(auto simp add: eq_upto_seq_inconsist_def split: action.split obs_event.split)

lemma eq_upto_seq_inconsist_Cons1:
  "eq_upto_seq_inconsist P (ob # obs) obs' vs 
   (ob' obs''. obs' = ob' # obs''  
      (case ob of NormalAction (ReadMem ad al v)  
         if (b. vs (ad, al) = (v, b)) 
         then ob' = ob  eq_upto_seq_inconsist P obs obs'' (mrw_value P vs ob)
         else ob  ob'
       | _  ob' = ob  eq_upto_seq_inconsist P obs obs'' (mrw_value P vs ob)))"
unfolding eq_upto_seq_inconsist_def
by(auto split: obs_event.split action.split simp add: foldl_list_all2_Cons1)

lemma eq_upto_seq_inconsist_appendD:
  assumes "eq_upto_seq_inconsist P (obs @ obs') obs'' vs"
  and "ta_seq_consist P vs (llist_of obs)"
  shows "length obs  length obs''" (is ?thesis1)
  and "take (length obs) obs'' = obs" (is ?thesis2)
  and "eq_upto_seq_inconsist P obs' (drop (length obs) obs'') (mrw_values P vs obs)" (is ?thesis3)
using assms
by(induct obs arbitrary: obs'' vs)(auto split: action.split_asm obs_event.split_asm simp add: eq_upto_seq_inconsist_Cons1)

lemma ta_seq_consist_imp_eq_upto_seq_inconsist_refl:
  "ta_seq_consist P vs (llist_of obs)  eq_upto_seq_inconsist P obs obs vs"
apply(induct obs arbitrary: vs)
apply(auto simp add: eq_upto_seq_inconsist_simps split: action.split obs_event.split)
done

context notes split_paired_Ex [simp del] eq_upto_seq_inconsist_simps [simp] begin

lemma eq_upto_seq_inconsist_appendI:
  " eq_upto_seq_inconsist P obs OBS vs;
      ta_seq_consist P vs (llist_of obs)   eq_upto_seq_inconsist P obs' OBS' (mrw_values P vs OBS) 
   eq_upto_seq_inconsist P (obs @ obs') (OBS @ OBS') vs"
apply(induct obs arbitrary: vs OBS)
 apply simp
apply(auto simp add: eq_upto_seq_inconsist_Cons1)
apply(simp split: action.split obs_event.split)
apply auto
done

lemma eq_upto_seq_inconsist_trans:
  " eq_upto_seq_inconsist P obs obs' vs; eq_upto_seq_inconsist P obs' obs'' vs 
   eq_upto_seq_inconsist P obs obs'' vs"
  apply(induction obs arbitrary: obs' obs'' vs)
  apply(clarsimp simp add: eq_upto_seq_inconsist_Cons1)+
  apply(auto split!: action.split obs_event.split if_split_asm)
  done

lemma eq_upto_seq_inconsist_append2:
  " eq_upto_seq_inconsist P obs obs' vs; ¬ ta_seq_consist P vs (llist_of obs) 
   eq_upto_seq_inconsist P obs (obs' @ obs'') vs"
  apply(induction obs arbitrary: obs' vs)
  apply(clarsimp simp add: eq_upto_seq_inconsist_Cons1)+
  apply(auto split!: action.split obs_event.split if_split_asm)
  done

end


context executions_sc_hb begin

lemma ta_seq_consist_mrwI:
  assumes E: "E  "
  and wf: "P  (E, ws) "
  and mrw: "a.  enat a < r; a  read_actions E   P,E  a ↝mrw ws a"
  shows "ta_seq_consist P Map.empty (lmap snd (ltake r E))"
proof(rule ta_seq_consist_nthI)
  fix i ad al v
  assume i_len: "enat i < llength (lmap snd (ltake r E))"
    and E_i: "lnth (lmap snd (ltake r E)) i = NormalAction (ReadMem ad al v)"
    and sc: "ta_seq_consist P Map.empty (ltake (enat i) (lmap snd (ltake r E)))"
  from i_len have "enat i < r" by simp
  with sc have "ta_seq_consist P Map.empty (ltake (enat i) (lmap snd E))"
    by(simp add: min_def split: if_split_asm)
  hence ns: "non_speculative P (λ_. {}) (ltake (enat i) (lmap snd E))"
    by(rule ta_seq_consist_into_non_speculative) simp
  from i_len have "i  actions E" by(simp add: actions_def)
  moreover from E_i i_len have obs_i: "action_obs E i = NormalAction (ReadMem ad al v)"
    by(simp add: action_obs_def lnth_ltake)
  ultimately have read: "i  read_actions E" ..
  with i_len have mrw_i: "P,E  i ↝mrw ws i" by(auto intro: mrw)
  with E have "ws i < i" using ns by(rule mrw_before)

  from mrw_i obs_i obtain adal_w: "(ad, al)  action_loc P E (ws i)"
    and adal_r: "(ad, al)  action_loc P E i"
    and "write": "ws i  write_actions E" by cases auto
  
  from wf have "is_write_seen P E ws" by(rule wf_exec_is_write_seenD)
  from is_write_seenD[OF this read obs_i]
  have vw_v: "value_written P E (ws i) (ad, al) = v" by simp

  let ?vs = "mrw_values P Map.empty (map snd (list_of (ltake (enat (ws i)) E)))"

  from ws i < i i_len have "enat (ws i) < llength (ltake (enat i) E)"
    by(simp add: less_trans[where y="enat i"])
  hence "ltake (enat i) E = lappend (ltake (enat (ws i)) (ltake (enat i) E)) (LCons (lnth (ltake (enat i) E) (ws i)) (ldropn (Suc (ws i)) (ltake (enat i) E)))"
    by(simp only: ldropn_Suc_conv_ldropn lappend_ltake_enat_ldropn)
  also have " = lappend (ltake (enat (ws i)) E) (LCons (lnth E (ws i)) (ldropn (Suc (ws i)) (ltake (enat i) E)))"
    using ws i < i i_len ‹enat (ws i) < llength (ltake (enat i) E) 
    by(simp add: lnth_ltake)(simp add: min_def)
  finally have r_E: "ltake (enat i) E = " .

  have "mrw_values P Map.empty (list_of (ltake (enat i) (lmap snd (ltake r E)))) (ad, al)
    = mrw_values P Map.empty (map snd (list_of (ltake (enat i) E))) (ad, al)"
    using ‹enat i < r by(auto simp add: min_def)
  also have " = mrw_values P (mrw_value P ?vs (snd (lnth E (ws i)))) (map snd (list_of (ldropn (Suc (ws i)) (ltake (enat i) E)))) (ad, al)"
    by(subst r_E)(simp add: list_of_lappend)
  also have " = mrw_value P ?vs (snd (lnth E (ws i))) (ad, al)"
  proof(rule mrw_values_no_write_unchanged)
    fix wa
    assume wa: "wa  set (map snd (list_of (ldropn (Suc (ws i)) (ltake (enat i) E))))"
      and "is_write_action wa" "(ad, al)  action_loc_aux P wa"

    from wa obtain w where "w < length (map snd (list_of (ldropn (Suc (ws i)) (ltake (enat i) E))))"
      and "map snd (list_of (ldropn (Suc (ws i)) (ltake (enat i) E))) ! w = wa"
      unfolding in_set_conv_nth by blast
    moreover hence "Suc (ws i + w) < i" (is "?w < _") using i_len 
      by(cases "llength E")(simp_all add: length_list_of_conv_the_enat)
    ultimately have obs_w': "action_obs E ?w = wa" using i_len
      by(simp add: action_obs_def lnth_ltake less_trans[where y="enat i"] ac_simps)
    from ?w < i i_len have "?w  actions E"
      by(simp add: actions_def less_trans[where y="enat i"])
    with ‹is_write_action wa obs_w' (ad, al)  action_loc_aux P wa
    have write': "?w  write_actions E" 
      and adal': "(ad, al)  action_loc P E ?w"
      by(auto intro: write_actions.intros)
      
    from ?w < i i  read_actions E ?w  actions E
    have "E  ?w ≤a i" by(auto simp add: action_order_def elim: read_actions.cases)

    from mrw_i adal_r write' adal'
    have "E  ?w ≤a ws i  E  i ≤a ?w" by(rule most_recent_write_recent)
    hence "E  ?w ≤a ws i"
    proof
      assume "E  i ≤a ?w"
      with E  ?w ≤a i have "?w = i" by(rule antisymPD[OF antisym_action_order])
      with write' read have False by(auto dest: read_actions_not_write_actions)
      thus ?thesis ..
    qed

    from adal_w "write" have "mrw_value P ?vs (snd (lnth E (ws i))) (ad, al)  None"
      by(cases "snd (lnth E (ws i))" rule: mrw_value_cases)
        (auto simp add: action_obs_def split: if_split_asm elim: write_actions.cases)
    then obtain b v where vb: "mrw_value P ?vs (snd (lnth E (ws i))) (ad, al) = Some (v, b)" by auto
    moreover
    from E  ?w ≤a ws i obs_w'
    have "is_new_action wa" "¬ is_new_action (action_obs E (ws i))" by(auto elim!: action_orderE)
    from ¬ is_new_action (action_obs E (ws i)) "write" adal_w
    obtain v' where "action_obs E (ws i) = NormalAction (WriteMem ad al v')"
      by(auto elim!: write_actions.cases is_write_action.cases)
    with vb have b by(simp add: action_obs_def)
    with ‹is_new_action wa vb 
    show "case mrw_value P ?vs (snd (lnth E (ws i))) (ad, al) of None  False | (v, b)  b  is_new_action wa" by simp
  qed
  also {
    fix v
    assume "?vs (ad, al) = Some (v, True)"
      and "is_new_action (action_obs E (ws i))"
    
    from mrw_values_eq_SomeD[OF this(1)]
    obtain wa where "wa  set (map snd (list_of (ltake (enat (ws i)) E)))"
      and "is_write_action wa"
      and "(ad, al)  action_loc_aux P wa"
      and "¬ is_new_action wa" by(fastforce simp del: set_map)
    moreover then obtain w where w: "w < ws i"  and wa: "wa = snd (lnth E w)"
      unfolding in_set_conv_nth by(cases "llength E")(auto simp add: lnth_ltake length_list_of_conv_the_enat)
    ultimately have "w  write_actions E" "action_obs E w = wa" "(ad, al)  action_loc P E w"
      using ws i  write_actions E
      by(auto intro!: write_actions.intros simp add: actions_def less_trans[where y="enat (ws i)"] action_obs_def elim!: write_actions.cases)
    with mrw_i adal_r have "E  w ≤a ws i  E  i ≤a w" by -(rule most_recent_write_recent)
    hence False
    proof
      assume "E  w ≤a ws i"
      moreover from ¬ is_new_action wa ‹is_new_action (action_obs E (ws i)) "write" w wa w  write_actions E
      have "E  ws i ≤a w" by(auto simp add: action_order_def action_obs_def)
      ultimately have "w = ws i" by(rule antisymPD[OF antisym_action_order])
      with w < ws i show False by simp
    next
      assume "E  i ≤a w"
      moreover from w  write_actions E w < ws i ws i < i read
      have "E  w ≤a i" by(auto simp add: action_order_def elim: read_actions.cases)
      ultimately have "i = w" by(rule antisymPD[OF antisym_action_order])
      with w < ws i ws i < i show False by simp
    qed }
  then obtain b where " = Some (v, b)" using vw_v "write" adal_w
    apply(atomize_elim)
    apply(auto simp add: action_obs_def value_written_def write_actions_iff)
    apply(erule is_write_action.cases)
    apply auto
    done
  finally show "b. mrw_values P Map.empty (list_of (ltake (enat i) (lmap snd (ltake r E)))) (ad, al) = (v, b)"
    by blast
qed

end

context jmm_multithreaded begin

definition complete_sc :: "('l,'thread_id,'x,'m,'w) state  ('addr × addr_loc  'addr val × bool)  
  ('thread_id × ('l, 'thread_id, 'x, 'm, 'w, ('addr, 'thread_id) obs_event action) thread_action) llist"
where
  "complete_sc s vs = unfold_llist
     (λ(s, vs). t ta s'. ¬ s -tta s')
     (λ(s, vs). fst (SOME ((t, ta), s'). s -tta s'  ta_seq_consist P vs (llist_of tao)))
     (λ(s, vs). let ((t, ta), s') = SOME ((t, ta), s'). s -tta s'  ta_seq_consist P vs (llist_of tao)
         in (s', mrw_values P vs tao))
     (s, vs)"

definition sc_completion :: "('l, 'thread_id, 'x, 'm, 'w) state  ('addr × addr_loc  'addr val × bool)  bool"
where
  "sc_completion s vs 
   (ttas s' t x ta x' m'.
       s -▹ttas→* s'  ta_seq_consist P vs (llist_of (concat (map (λ(t, ta). tao) ttas))) 
       thr s' t = (x, no_wait_locks)  t  (x, shr s') -ta (x', m')  actions_ok s' t ta 
       (ta' x'' m''. t  (x, shr s') -ta' (x'', m'')  actions_ok s' t ta' 
                      ta_seq_consist P (mrw_values P vs (concat (map (λ(t, ta). tao) ttas))) (llist_of ta'o)))"

lemma sc_completionD:
  " sc_completion s vs; s -▹ttas→* s'; ta_seq_consist P vs (llist_of (concat (map (λ(t, ta). tao) ttas))); 
     thr s' t = (x, no_wait_locks); t  (x, shr s') -ta (x', m'); actions_ok s' t ta 
   ta' x'' m''. t  (x, shr s') -ta' (x'', m'')  actions_ok s' t ta' 
                   ta_seq_consist P (mrw_values P vs (concat (map (λ(t, ta). tao) ttas))) (llist_of ta'o)"
unfolding sc_completion_def by blast

lemma sc_completionI:
  "(ttas s' t x ta x' m'. 
      s -▹ttas→* s'; ta_seq_consist P vs (llist_of (concat (map (λ(t, ta). tao) ttas))); 
       thr s' t = (x, no_wait_locks); t  (x, shr s') -ta (x', m'); actions_ok s' t ta 
      ta' x'' m''. t  (x, shr s') -ta' (x'', m'')  actions_ok s' t ta' 
                   ta_seq_consist P (mrw_values P vs (concat (map (λ(t, ta). tao) ttas))) (llist_of ta'o))
   sc_completion s vs"
unfolding sc_completion_def by blast

lemma sc_completion_shift:
  assumes sc_c: "sc_completion s vs"
  and τRed: "s -▹ttas→* s'"
  and sc: "ta_seq_consist P vs (lconcat (lmap (λ(t, ta). llist_of tao) (llist_of ttas)))"
  shows "sc_completion s' (mrw_values P vs (concat (map (λ(t, ta). tao) ttas)))"
proof(rule sc_completionI)
  fix ttas' s'' t x ta x' m'
  assume τRed': "s' -▹ttas'→* s''"
    and sc': "ta_seq_consist P (mrw_values P vs (concat (map (λ(t, ta). tao) ttas))) (llist_of (concat (map (λ(t, ta). tao) ttas')))"
    and red: "thr s'' t = (x, no_wait_locks)" "t  x, shr s'' -ta x', m'" "actions_ok s'' t ta" 
  from τRed τRed' have "s -▹ttas @ ttas'→* s''" unfolding RedT_def by(rule rtrancl3p_trans)
  moreover from sc sc' have "ta_seq_consist P vs (llist_of (concat (map (λ(t, ta). tao) (ttas @ ttas'))))"
    apply(simp add: lappend_llist_of_llist_of[symmetric] ta_seq_consist_lappend del: lappend_llist_of_llist_of)
    apply(simp add: lconcat_llist_of[symmetric] lmap_llist_of[symmetric] llist.map_comp o_def split_def del: lmap_llist_of)
    done
  ultimately
  show "ta' x'' m''. t  x, shr s'' -ta' x'', m''  actions_ok s'' t ta' 
         ta_seq_consist P (mrw_values P (mrw_values P vs (concat (map (λ(t, ta). tao) ttas))) (concat (map (λ(t, ta). tao) ttas'))) (llist_of ta'o)"
    using red unfolding foldl_append[symmetric] concat_append[symmetric] map_append[symmetric]
    by(rule sc_completionD[OF sc_c])
qed

lemma complete_sc_in_Runs:
  assumes cau: "sc_completion s vs"
  and ta_seq_consist_convert_RA: "vs ln. ta_seq_consist P vs (llist_of (convert_RA ln))"
  shows "mthr.Runs s (complete_sc s vs)"
proof -
  let ?ttas' = "λttas' :: ('thread_id × ('l,'thread_id,'x,'m,'w, ('addr, 'thread_id) obs_event action) thread_action) list.
               concat (map (λ(t, ta). tao) ttas')"
  let "?vs ttas'" = "mrw_values P vs (?ttas' ttas')"

  define s' vs'
    and ttas :: "('thread_id × ('l,'thread_id,'x,'m,'w, ('addr, 'thread_id) obs_event action) thread_action) list"
    where "s' = s" and "vs' = vs" and "ttas = []"
  hence "s -▹ttas→* s'" "ta_seq_consist P vs (llist_of (?ttas' ttas))" by auto
  hence "mthr.Runs s' (complete_sc s' (?vs ttas))"
  proof(coinduction arbitrary: s' ttas rule: mthr.Runs.coinduct)
    case (Runs s' ttas')
    note Red = s -▹ttas'→* s'
      and sc = ‹ta_seq_consist P vs (llist_of (?ttas' ttas'))
    show ?case
    proof(cases "t' ta' s''. s' -t'ta' s''")
      case False
      hence ?Stuck by(simp add: complete_sc_def)
      thus ?thesis ..
    next
      case True
      let ?proceed = "λ((t', ta'), s''). s' -t'ta' s''  ta_seq_consist P (?vs ttas') (llist_of ta'o)"
      from True obtain t' ta' s'' where red: "s' -t'ta' s''" by(auto)
      then obtain ta'' s''' where "s' -t'ta'' s'''"
        and "ta_seq_consist P (?vs ttas') (llist_of ta''o)"
      proof(cases)
        case (redT_normal x x' m')
        note red = t'  x, shr s' -ta' x', m'
          and ts''t' = ‹thr s' t' = (x, no_wait_locks)
          and aok = ‹actions_ok s' t' ta'
          and s'' = ‹redT_upd s' t' ta' x' m' s''
        from sc_completionD[OF cau Red sc ts''t' red aok]
        obtain ta'' x'' m'' where red': "t'  x, shr s' -ta'' x'', m''"
          and aok': "actions_ok s' t' ta''"
          and sc': "ta_seq_consist P (?vs ttas') (llist_of ta''o)" by blast
        from redT_updWs_total obtain ws' where "redT_updWs t' (wset s') ta''w ws'" ..
        then obtain s''' where "redT_upd s' t' ta'' x'' m'' s'''" by fastforce
        with red' ts''t' aok' have "s' -t'ta'' s'''" ..
        thus thesis using sc' by(rule that)
      next
        case redT_acquire
        thus thesis by(simp add: that[OF red] ta_seq_consist_convert_RA)
      qed
      hence "?proceed ((t', ta''), s''')" using Red by(auto)
      hence *: "?proceed (Eps ?proceed)" by(rule someI)
      moreover from Red * have "s -▹ttas' @ [fst (Eps ?proceed)]→* snd (Eps ?proceed)"
        by(auto simp add: split_beta RedT_def intro: rtrancl3p_step)
      moreover from True
      have "complete_sc s' (?vs ttas') = LCons (fst (Eps ?proceed)) (complete_sc (snd (Eps ?proceed)) (?vs (ttas' @ [fst (Eps ?proceed)])))"
        unfolding complete_sc_def by(simp add: split_def)
      moreover from sc ?proceed (Eps ?proceed)
      have "ta_seq_consist P vs (llist_of (?ttas' (ttas' @ [fst (Eps ?proceed)])))"
        unfolding map_append concat_append lappend_llist_of_llist_of[symmetric] 
        by(subst ta_seq_consist_lappend)(auto simp add: split_def)
      ultimately have ?Step
        by(fastforce intro: exI[where x="ttas' @ [fst (Eps ?proceed)]"] simp del: split_paired_Ex)
      thus ?thesis by simp
    qed
  qed
  thus ?thesis by(simp add: s'_def ttas_def)
qed

lemma complete_sc_ta_seq_consist:
  assumes cau: "sc_completion s vs"
  and ta_seq_consist_convert_RA: "vs ln. ta_seq_consist P vs (llist_of (convert_RA ln))"
  shows "ta_seq_consist P vs (lconcat (lmap (λ(t, ta). llist_of tao) (complete_sc s vs)))"
proof -
  define vs' where "vs' = vs"
  let ?obs = "λttas. lconcat (lmap (λ(t, ta). llist_of tao) ttas)"
  define obs where "obs = ?obs (complete_sc s vs)"
  define a where "a = complete_sc s vs'"
  let ?ttas' = "λttas' :: ('thread_id × ('l,'thread_id,'x,'m,'w,('addr, 'thread_id) obs_event action) thread_action) list.
               concat (map (λ(t, ta). tao) ttas')"
  let ?vs = "λttas'. mrw_values P vs (?ttas' ttas')"
  from vs'_def obs_def
  have "s -▹[]→* s" "ta_seq_consist P vs (llist_of (?ttas' []))" "vs' = ?vs []" by(auto)
  hence "s' ttas'. obs = ?obs (complete_sc s' vs')  s -▹ttas'→* s'  
                    ta_seq_consist P vs (llist_of (?ttas' ttas'))  vs' = ?vs ttas'  
                    a = complete_sc s' vs'"
    unfolding obs_def vs'_def a_def by metis
  moreover have "wf (inv_image {(m, n). m < n} (llength  ltakeWhile (λ(t, ta). tao = [])))"
    (is "wf ?R") by(rule wf_inv_image)(rule wellorder_class.wf)
  ultimately show "ta_seq_consist P vs' obs"
  proof(coinduct vs' obs a rule: ta_seq_consist_coinduct_append_wf)
    case (ta_seq_consist vs' obs a)
    then obtain s' ttas' where obs_def: "obs = ?obs (complete_sc s' (?vs ttas'))"
      and Red: "s -▹ttas'→* s'"
      and sc: "ta_seq_consist P vs (llist_of (?ttas' ttas'))"
      and vs'_def: "vs' = ?vs ttas'" 
      and a_def: "a = complete_sc s' vs'" by blast

    show ?case
    proof(cases "t' ta' s''. s' -t'ta' s''")
      case False
      hence "obs = LNil" unfolding obs_def complete_sc_def by simp
      hence ?LNil unfolding obs_def by auto
      thus ?thesis ..
    next
      case True
      let ?proceed = "λ((t', ta'), s''). s' -t'ta' s''  ta_seq_consist P (?vs ttas') (llist_of ta'o)"
      let ?tta = "fst (Eps ?proceed)"
      let ?s' = "snd (Eps ?proceed)"

      from True obtain t' ta' s'' where red: "s' -t'ta' s''" by blast
      then obtain ta'' s''' where "s' -t'ta'' s'''"
        and "ta_seq_consist P (?vs ttas') (llist_of ta''o)"
      proof(cases)
        case (redT_normal x x' m')
        note red = t'  x, shr s' -ta' x', m'
          and ts''t' = ‹thr s' t' = (x, no_wait_locks)
          and aok = ‹actions_ok s' t' ta'
          and s''' = ‹redT_upd s' t' ta' x' m' s''
        from sc_completionD[OF cau Red sc ts''t' red aok]
        obtain ta'' x'' m'' where red': "t'  x, shr s' -ta'' x'', m''"
          and aok': "actions_ok s' t' ta''"
          and sc': "ta_seq_consist P (?vs ttas') (llist_of ta''o)" by blast
        from redT_updWs_total obtain ws' where "redT_updWs t' (wset s') ta''w ws'" ..
        then obtain s''' where "redT_upd s' t' ta'' x'' m'' s'''" by fastforce
        with red' ts''t' aok' have "s' -t'ta'' s'''" ..
        thus thesis using sc' by(rule that)
      next
        case redT_acquire
        thus thesis by(simp add: that[OF red] ta_seq_consist_convert_RA)
      qed
      hence "?proceed ((t', ta''), s''')" by auto
      hence "?proceed (Eps ?proceed)" by(rule someI)
      show ?thesis
      proof(cases "obs = LNil")
        case True thus ?thesis ..
      next
        case False
        from True
        have csc_unfold: "complete_sc s' (?vs ttas') = LCons ?tta (complete_sc ?s' (?vs (ttas' @ [?tta])))"
          unfolding complete_sc_def by(simp add: split_def)
        hence "obs = lappend (llist_of snd ?ttao) (?obs (complete_sc ?s' (?vs (ttas' @ [?tta]))))"
          using obs_def by(simp add: split_beta)
        moreover have "ta_seq_consist P vs' (llist_of snd ?ttao)"
          using ?proceed (Eps ?proceed) vs'_def by(clarsimp simp add: split_beta)
        moreover {
          assume "llist_of snd ?ttao = LNil"
          moreover from obs_def obs  LNil›
          have "lfinite (ltakeWhile (λ(t, ta). tao = []) (complete_sc s' (?vs ttas')))"
            unfolding lfinite_ltakeWhile by(fastforce simp add: split_def lconcat_eq_LNil)
          ultimately have "(complete_sc ?s' (?vs (ttas' @ [?tta])), a)  ?R"
            unfolding a_def vs'_def csc_unfold
            by(clarsimp simp add: split_def llist_of_eq_LNil_conv)(auto simp add: lfinite_eq_range_llist_of) }
        moreover have "?obs (complete_sc ?s' (?vs (ttas' @ [?tta]))) = ?obs (complete_sc ?s' (mrw_values P vs' (list_of (llist_of snd ?ttao))))"
          unfolding vs'_def by(simp add: split_def)
        moreover from ?proceed (Eps ?proceed) Red
        have "s -▹ttas' @ [?tta]→* ?s'" by(auto simp add: RedT_def split_def intro: rtrancl3p_step)
        moreover from sc ?proceed (Eps ?proceed)
        have "ta_seq_consist P vs (llist_of (?ttas' (ttas' @ [?tta])))"
          by(clarsimp simp add: split_def ta_seq_consist_lappend lappend_llist_of_llist_of[symmetric] simp del: lappend_llist_of_llist_of)
        moreover have "mrw_values P vs' (list_of (llist_of snd ?ttao)) = ?vs (ttas' @ [?tta])" 
          unfolding vs'_def by(simp add: split_def)
        moreover have "complete_sc ?s' (?vs (ttas' @ [?tta])) = complete_sc ?s' (mrw_values P vs' (list_of (llist_of snd ?ttao)))"
          unfolding vs'_def by(simp add: split_def)
        ultimately have "?lappend" by blast
        thus ?thesis ..
      qed
    qed
  qed
qed

lemma sequential_completion_Runs:
  assumes "sc_completion s vs"
  and "vs ln. ta_seq_consist P vs (llist_of (convert_RA ln))"
  shows "ttas. mthr.Runs s ttas  ta_seq_consist P vs (lconcat (lmap (λ(t, ta). llist_of tao) ttas))"
using complete_sc_ta_seq_consist[OF assms] complete_sc_in_Runs[OF assms]
by blast


definition cut_and_update :: "('l, 'thread_id, 'x, 'm, 'w) state  ('addr × addr_loc  'addr val × bool)  bool"
where
  "cut_and_update s vs 
   (ttas s' t x ta x' m'.
      s -▹ttas→* s'  ta_seq_consist P vs (llist_of (concat (map (λ(t, ta). tao) ttas))) 
      thr s' t = (x, no_wait_locks)  t  (x, shr s') -ta (x', m')  actions_ok s' t ta  
   (ta' x'' m''. t  (x, shr s') -ta' (x'', m'')  actions_ok s' t ta' 
                   ta_seq_consist P (mrw_values P vs (concat (map (λ(t, ta). tao) ttas))) (llist_of ta'o) 
                   eq_upto_seq_inconsist P tao ta'o (mrw_values P vs (concat (map (λ(t, ta). tao) ttas)))))"

lemma cut_and_updateI[intro?]:
  "(ttas s' t x ta x' m'. 
      s -▹ttas→* s'; ta_seq_consist P vs (llist_of (concat (map (λ(t, ta). tao) ttas)));
       thr s' t = (x, no_wait_locks); t  (x, shr s') -ta (x', m'); actions_ok s' t ta 
       ta' x'' m''. t  (x, shr s') -ta' (x'', m'')  actions_ok s' t ta'  
                       ta_seq_consist P (mrw_values P vs (concat (map (λ(t, ta). tao) ttas))) (llist_of ta'o) 
                       eq_upto_seq_inconsist P tao ta'o (mrw_values P vs (concat (map (λ(t, ta). tao) ttas))))
     cut_and_update s vs"
unfolding cut_and_update_def by blast

lemma cut_and_updateD:
  " cut_and_update s vs; s -▹ttas→* s'; ta_seq_consist P vs (llist_of (concat (map (λ(t, ta). tao) ttas)));
     thr s' t = (x, no_wait_locks); t  (x, shr s') -ta (x', m'); actions_ok s' t ta 
   ta' x'' m''. t  (x, shr s') -ta' (x'', m'')  actions_ok s' t ta'  
                   ta_seq_consist P (mrw_values P vs (concat (map (λ(t, ta). tao) ttas))) (llist_of ta'o) 
                   eq_upto_seq_inconsist P tao ta'o (mrw_values P vs (concat (map (λ(t, ta). tao) ttas)))"
unfolding cut_and_update_def by blast

lemma cut_and_update_imp_sc_completion:
  "cut_and_update s vs  sc_completion s vs"
apply(rule sc_completionI)
apply(drule (5) cut_and_updateD)
apply blast
done

lemma sequential_completion:
  assumes cut_and_update: "cut_and_update s vs"
  and ta_seq_consist_convert_RA: "vs ln. ta_seq_consist P vs (llist_of (convert_RA ln))"
  and Red: "s -▹ttas→* s'"
  and sc: "ta_seq_consist P vs (llist_of (concat (map (λ(t, ta). tao) ttas)))"
  and red: "s' -tta s''"
  shows
  "ta' ttas'. mthr.Runs s' (LCons (t, ta') ttas')  
     ta_seq_consist P vs (lconcat (lmap (λ(t, ta). llist_of tao) (lappend (llist_of ttas) (LCons (t, ta') ttas'))))  
     eq_upto_seq_inconsist P tao ta'o (mrw_values P vs (concat (map (λ(t, ta). tao) ttas)))"
proof -
  from red obtain ta' s''' 
    where red': "redT s' (t, ta') s'''"
    and sc': "ta_seq_consist P vs (lconcat (lmap (λ(t, ta). llist_of tao) (lappend (llist_of ttas) (LCons (t, ta') LNil))))"
    and eq: "eq_upto_seq_inconsist P tao ta'o (mrw_values P vs (concat (map (λ(t, ta). tao) ttas)))"
  proof cases
    case (redT_normal x x' m')
    note ts't = ‹thr s' t = (x, no_wait_locks)
      and red = t  x, shr s' -ta x', m'
      and aok = ‹actions_ok s' t ta
      and s'' = ‹redT_upd s' t ta x' m' s''
    from cut_and_updateD[OF cut_and_update, OF Red sc ts't red aok]
    obtain ta' x'' m'' where red: "t  x, shr s' -ta' x'', m''"
      and sc': "ta_seq_consist P (mrw_values P vs (concat (map (λ(t, y). yo) ttas))) (llist_of ta'o)"
      and eq: "eq_upto_seq_inconsist P tao ta'o (mrw_values P vs (concat (map (λ(t, ta). tao) ttas)))"
      and aok: "actions_ok s' t ta'" by blast
    obtain ws''' where "redT_updWs t (wset s') ta'w ws'''"
      using redT_updWs_total ..
    then obtain s''' where s''': "redT_upd s' t ta' x'' m'' s'''" by fastforce
    with red ‹thr s' t = (x, no_wait_locks) aok have "s' -tta' s'''" by(rule redT.redT_normal)
    moreover from sc sc'
    have "ta_seq_consist P vs (lconcat (lmap (λ(t, ta). llist_of tao) (lappend (llist_of ttas) (LCons (t, ta') LNil))))"
      by(auto simp add: lmap_lappend_distrib ta_seq_consist_lappend split_def lconcat_llist_of[symmetric] o_def list_of_lconcat)
    ultimately show thesis using eq by(rule that)
  next
    case (redT_acquire x ln n)
    hence "ta_seq_consist P vs (lconcat (lmap (λ(t, ta). llist_of tao) (lappend (llist_of ttas) (LCons (t, ta) LNil))))"
      and "eq_upto_seq_inconsist P tao tao (mrw_values P vs (concat (map (λ(t, ta). tao) ttas)))"
      using sc
      by(simp_all add: lmap_lappend_distrib ta_seq_consist_lappend split_def lconcat_llist_of[symmetric] o_def list_of_lconcat ta_seq_consist_convert_RA ta_seq_consist_imp_eq_upto_seq_inconsist_refl)
    with red show thesis by(rule that)
  qed

  txt ‹Now, find a sequentially consistent completion from @{term "s'''"} onwards.›
  from Red red' have Red': "s -▹ttas @ [(t, ta')]→* s'''"
    unfolding RedT_def by(auto intro: rtrancl3p_step)

  from sc sc'
  have "ta_seq_consist P vs (lconcat (lmap (λ(t, ta). llist_of tao) (llist_of (ttas @ [(t, ta')]))))"
    by(simp add: o_def split_def lappend_llist_of_llist_of[symmetric])
  with cut_and_update_imp_sc_completion[OF cut_and_update] Red'
  have "sc_completion s''' (mrw_values P vs (concat (map (λ(t, ta). tao) (ttas @ [(t, ta')]))))"
    by(rule sc_completion_shift)
  from sequential_completion_Runs[OF this ta_seq_consist_convert_RA]
  obtain ttas' where τRuns: "mthr.Runs s''' ttas'"
    and sc'': "ta_seq_consist P (mrw_values P vs (concat (map (λ(t, ta). tao) (ttas @ [(t, ta')])))) 
                                (lconcat (lmap (λ(t, ta). llist_of tao) ttas'))"
    by blast
  from red' τRuns have "mthr.Runs s' (LCons (t, ta') ttas')" ..
  moreover from sc sc' sc''
  have "ta_seq_consist P vs (lconcat (lmap (λ(t, ta). llist_of tao) (lappend (llist_of ttas) (LCons (t, ta') ttas'))))"
    unfolding lmap_lappend_distrib lconcat_lappend by(simp add: o_def ta_seq_consist_lappend split_def list_of_lconcat)
  ultimately show ?thesis using eq by blast
qed

end

end

Theory HB_Completion

(*  Title:      JinjaThreads/MM/HB_Completion.thy
    Author:     Andreas Lochbihler
*)

section ‹Happens-before consistent completion of executions in the JMM›

theory HB_Completion imports
  Non_Speculative
begin

coinductive ta_hb_consistent :: "'m prog  ('thread_id × ('addr, 'thread_id) obs_event action) list  ('thread_id × ('addr, 'thread_id) obs_event action) llist  bool"
for P :: "'m prog"
where
  LNil: "ta_hb_consistent P obs LNil" 
| LCons:
  " ta_hb_consistent P (obs @ [ob]) obs';
     case ob of (t, NormalAction (ReadMem ad al v))
         (w. w  write_actions (llist_of (obs @ [ob]))  (ad, al)  action_loc P (llist_of (obs @ [ob])) w 
               value_written P (llist_of (obs @ [ob])) w (ad, al) = v 
             P,llist_of (obs @ [ob])  w ≤hb length obs 
             (w'write_actions (llist_of (obs @ [ob])). (ad, al)  action_loc P (llist_of (obs @ [ob])) w'  
                (P,llist_of (obs @ [ob])  w ≤hb w'  P,llist_of (obs @ [ob])  w' ≤hb length obs  
                   is_volatile P al  P,llist_of (obs @ [ob])  w ≤so w'  P,llist_of (obs @ [ob])  w' ≤so length obs)  
                w' = w))
     | _  True  
   ta_hb_consistent P obs (LCons ob obs')"

inductive_simps ta_hb_consistent_LNil [simp]:
  "ta_hb_consistent P obs LNil"

inductive_simps ta_hb_consistent_LCons:
  "ta_hb_consistent P obs (LCons ob obs')"

lemma ta_hb_consistent_into_non_speculative:
  "ta_hb_consistent P obs0 obs
   non_speculative P (w_values P (λ_. {}) (map snd obs0)) (lmap snd obs)"
proof(coinduction arbitrary: obs0 obs)
  case (non_speculative obs0 obs)
  let ?vs = "w_values P (λ_. {}) (map snd obs0)"
  let ?CH = "λvs obs'. obs0 obs. vs = w_values P (λ_. {}) (map snd obs0)  obs' = lmap snd obs  ta_hb_consistent P obs0 obs"
  from non_speculative show ?case
  proof(cases)
    case LNil hence ?LNil by simp
    thus ?thesis ..
  next
    case (LCons tob obs'')
    note obs = obs = LCons tob obs''
    obtain t ob where tob: "tob = (t, ob)" by(cases tob)
    from ‹ta_hb_consistent P (obs0 @ [tob]) obs'' tob obs
    have "?CH (w_value P ?vs ob) (lmap snd obs'')" by(auto intro!: exI)
    moreover {
      fix ad al v
      assume ob: "ob = NormalAction (ReadMem ad al v)"
      with LCons tob obtain w where w: "w  write_actions (llist_of (obs0 @ [tob]))"
        and adal: "(ad, al)  action_loc P (llist_of (obs0 @ [tob])) w"
        and v: "value_written P (llist_of (obs0 @ [tob])) w (ad, al) = v" by auto
      from w obtain "is_write_action (action_obs (llist_of (obs0 @ [tob])) w)" 
        and w_actions: "w  actions (llist_of (obs0 @ [tob]))" by cases
      hence "v  ?vs (ad, al)"
      proof(cases)
        case (WriteMem ad' al' v')
        hence "NormalAction (WriteMem ad al v)  set (map snd obs0)"
          using adal ob tob v w_actions unfolding in_set_conv_nth
          by(auto simp add: action_obs_def nth_append value_written.simps actions_def cong: conj_cong split: if_split_asm)
        thus ?thesis by(rule w_values_WriteMemD)
      next
        case (NewHeapElem ad' hT)
        hence "NormalAction (NewHeapElem ad hT)  set (map snd obs0)"
          using adal ob tob v w_actions unfolding in_set_conv_nth
          by(auto simp add: action_obs_def nth_append value_written.simps actions_def cong: conj_cong split: if_split_asm)
        thus ?thesis using NewHeapElem adal unfolding v[symmetric]
          by(fastforce simp add: value_written.simps intro!: w_values_new_actionD intro: rev_image_eqI)
      qed }
    hence "case ob of NormalAction (ReadMem ad al v)  v  ?vs (ad, al) | _  True"
      by(simp split: action.split obs_event.split)
    ultimately have ?LCons using obs tob by simp
    thus ?thesis ..
  qed
qed

lemma ta_hb_consistent_lappendI:
  assumes hb1: "ta_hb_consistent P E E'"
  and hb2: "ta_hb_consistent P (E @ list_of E') E''"
  and fin: "lfinite E'"
  shows "ta_hb_consistent P E (lappend E' E'')"
using fin hb1 hb2
proof(induction arbitrary: E)
  case lfinite_LNil thus ?case by simp
next
  case (lfinite_LConsI E' tob)
  from ‹ta_hb_consistent P E (LCons tob E')
  have "ta_hb_consistent P (E @ [tob]) E'" by cases
  moreover from ‹ta_hb_consistent P (E @ list_of (LCons tob E')) E'' ‹lfinite E'
  have "ta_hb_consistent P ((E @ [tob]) @ list_of E') E''" by simp
  ultimately have "ta_hb_consistent P (E @ [tob]) (lappend E' E'')" by(rule lfinite_LConsI.IH)
  thus ?case unfolding lappend_code apply(rule ta_hb_consistent.LCons)
    using ‹ta_hb_consistent P E (LCons tob E')
    by cases (simp split: prod.split_asm action.split_asm obs_event.split_asm)
qed

lemma ta_hb_consistent_coinduct_append
  [consumes 1, case_names ta_hb_consistent, case_conclusion ta_hb_consistent LNil lappend]:
  assumes major: "X E tobs"
  and step: "E tobs. X E tobs 
     tobs = LNil 
       (tobs' tobs''. tobs = lappend tobs' tobs''  tobs'  LNil  ta_hb_consistent P E tobs' 
                    (lfinite tobs'  (X (E @ list_of tobs') tobs'' 
                                       ta_hb_consistent P (E @ list_of tobs') tobs'')))"
    (is "E tobs. _  _  ?step E tobs")
  shows "ta_hb_consistent P E tobs"
proof -
  from major
  have "tobs' tobs''. tobs = lappend (llist_of tobs') tobs''  ta_hb_consistent P E (llist_of tobs')  
                     X (E @ tobs') tobs''"
    by(auto intro: exI[where x="[]"])
  thus ?thesis
  proof(coinduct)
    case (ta_hb_consistent E tobs)
    then obtain tobs' tobs'' 
      where tobs: "tobs = lappend (llist_of tobs') tobs''"
      and hb_tobs': "ta_hb_consistent P E (llist_of tobs')"
      and X: "X (E @ tobs') tobs''" by blast

    show ?case
    proof(cases tobs')
      case Nil
      with X have "X E tobs''" by simp
      from step[OF this] show ?thesis
      proof
        assume "tobs'' = LNil" 
        with Nil tobs show ?thesis by simp
      next
        assume "?step E tobs''"
        then obtain tobs''' tobs'''' 
          where tobs'': "tobs'' = lappend tobs''' tobs''''" and "tobs'''  LNil"
          and sc_obs''': "ta_hb_consistent P E tobs'''" 
          and fin: "lfinite tobs'''  X (E @ list_of tobs''') tobs'''' 
                                      ta_hb_consistent P (E @ list_of tobs''') tobs''''"
          by blast
        from tobs'''  LNil› obtain t ob tobs''''' where tobs''': "tobs''' = LCons (t, ob) tobs'''''"
          unfolding neq_LNil_conv by auto
        with Nil tobs'' tobs have concl1: "tobs = LCons (t, ob) (lappend tobs''''' tobs'''')" by simp
        
        have ?LCons
        proof(cases "lfinite tobs'''")
          case False
          hence "lappend tobs''''' tobs'''' = tobs'''''" using tobs''' by(simp add: lappend_inf)
          hence "ta_hb_consistent P (E @ [(t, ob)]) (lappend tobs''''' tobs'''')" 
            using sc_obs''' tobs''' by(simp add: ta_hb_consistent_LCons)
          with concl1 show ?LCons apply(simp)
            using sc_obs'''[unfolded tobs'''] by cases simp
        next
          case True
          with tobs''' obtain tobs'''''' where tobs''''': "tobs''''' = llist_of tobs''''''"
            by simp(auto simp add: lfinite_eq_range_llist_of)
          from fin[OF True] 
          have "ta_hb_consistent P (E @ [(t, ob)]) (llist_of tobs'''''')  X (E @ (t, ob) # tobs'''''') tobs''''  
                ta_hb_consistent P (E @ [(t, ob)]) (lappend (llist_of tobs'''''') tobs'''')"
          proof
            assume X: "X (E @ list_of tobs''') tobs''''"
            hence "X (E @ (t, ob) # tobs'''''') tobs''''" using tobs''''' tobs''' by simp
            moreover have "ta_hb_consistent P (E @ [(t, ob)]) (llist_of tobs'''''')"
              using sc_obs''' tobs''' tobs''''' by(simp add: ta_hb_consistent_LCons)
            ultimately show ?thesis by simp
          next
            assume "ta_hb_consistent P (E @ list_of tobs''') tobs''''"
            with sc_obs''' tobs''''' tobs'''
            have "ta_hb_consistent P (E @ [(t, ob)]) (lappend (llist_of tobs'''''') tobs'''')"
              by(simp add: ta_hb_consistent_LCons ta_hb_consistent_lappendI)
            thus ?thesis ..
          qed
          hence "((tobs' tobs''. lappend (llist_of tobs'''''') tobs'''' = lappend (llist_of tobs') tobs'' 
                                  ta_hb_consistent P (E @ [(t, ob)]) (llist_of tobs')  X (E @ (t, ob) # tobs') tobs'') 
                 ta_hb_consistent P (E @ [(t, ob)]) (lappend (llist_of tobs'''''') tobs''''))"
            by auto
          thus "?LCons" using concl1 tobs''''' apply(simp)
            using sc_obs'''[unfolded tobs'''] by cases simp
        qed
        thus ?thesis ..
      qed
    next
      case (Cons tob tobs''')
      with X tobs hb_tobs' show ?thesis by(auto simp add: ta_hb_consistent_LCons)
    qed
  qed
qed

lemma ta_hb_consistent_coinduct_append_wf
  [consumes 2, case_names ta_hb_consistent, case_conclusion ta_hb_consistent LNil lappend]:
  assumes major: "X E obs a"
  and wf: "wf R"
  and step: "E obs a. X E obs a
     obs = LNil 
       (obs' obs'' a'. obs = lappend obs' obs''  ta_hb_consistent P E obs'  (obs' = LNil  (a', a)  R) 
                        (lfinite obs'  X (E @ list_of obs') obs'' a' 
                                          ta_hb_consistent P (E @ list_of obs') obs''))"
    (is "E obs a. _  _  ?step E obs a")
  shows "ta_hb_consistent P E obs"
proof -
  { fix E obs a
    assume "X E obs a"
    with wf
    have "obs = LNil  (obs' obs''. obs = lappend obs' obs''  obs'  LNil  ta_hb_consistent P E obs' 
          (lfinite obs'  (a. X (E @ list_of obs') obs'' a)  
                            ta_hb_consistent P (E @ list_of obs') obs''))"
      (is "_  ?step_concl E obs")
    proof(induction a arbitrary: E obs rule: wf_induct[consumes 1, case_names wf])
      case (wf a)
      note IH = wf.IH[rule_format]
      from step[OF X E obs a]
      show ?case
      proof
        assume "obs = LNil" thus ?thesis ..
      next
        assume "?step E obs a"
        then obtain obs' obs'' a'
          where obs: "obs = lappend obs' obs''"
          and sc_obs': "ta_hb_consistent P E obs'"
          and decr: "obs' = LNil  (a', a)  R"
          and fin: "lfinite obs'  
                    X (E @ list_of obs') obs'' a' 
                    ta_hb_consistent P (E @ list_of obs') obs''"
          by blast
        show ?case
        proof(cases "obs' = LNil")
          case True
          hence "lfinite obs'" by simp
          from fin[OF this] show ?thesis
          proof
            assume X: "X (E @ list_of obs') obs'' a'"
            from True have "(a', a)  R" by(rule decr)
            from IH[OF this X] show ?thesis
            proof
              assume "obs'' = LNil"
              with True obs have "obs = LNil" by simp
              thus ?thesis ..
            next
              assume "?step_concl (E @ list_of obs') obs''"
              hence "?step_concl E obs" using True obs by simp
              thus ?thesis ..
            qed
          next
            assume "ta_hb_consistent P (E @ list_of obs') obs''"
            thus ?thesis using obs True
              by cases (auto 4 3 cong: action.case_cong obs_event.case_cong intro: exI[where x="LCons x LNil" for x] simp add: ta_hb_consistent_LCons)
          qed
        next
          case False
          with obs sc_obs' fin show ?thesis by auto
        qed
      qed
    qed }
  note step' = this

  from major show ?thesis
  proof(coinduction arbitrary: E obs a rule: ta_hb_consistent_coinduct_append)
    case (ta_hb_consistent E obs)
    thus ?case by simp(rule step')
  qed
qed

lemma ta_hb_consistent_lappendD2:
  assumes hb: "ta_hb_consistent P E (lappend E' E'')"
  and fin: "lfinite E'"
  shows "ta_hb_consistent P (E @ list_of E') E''"
using fin hb
by(induct arbitrary: E)(fastforce simp add: ta_hb_consistent_LCons)+

lemma ta_hb_consistent_Read_hb:
  fixes E E' defines "E''  lappend (llist_of E') E"
  assumes hb: "ta_hb_consistent P E' E"
  and tsa: "thread_start_actions_ok E''"
  and E'': "is_write_seen P (llist_of E') ws'"
  and new_actions_for_fun: 
  "w w' adal.  w  new_actions_for P E'' adal; 
                 w'  new_actions_for P E'' adal   w = w'"
  shows "ws. P  (E'', ws)   (n. n  read_actions E''  length E'  n  P,E''  ws n ≤hb n)  
              (n. n < length E'  ws n = ws' n)"
proof(intro exI conjI strip)
  let ?P = 
    "λn w. case lnth E'' n of
        (t, NormalAction (ReadMem ad al v))  
          (w  write_actions E''  (ad, al)  action_loc P E'' w  value_written P E'' w (ad, al) = v 
          P,E''  w ≤hb n  
          (w'write_actions E''. (ad, al)  action_loc P E'' w'  
              (P,E''  w ≤hb w'  P,E''  w' ≤hb n  
               is_volatile P al  P,E''  w ≤so w'  P,E''  w' ≤so n)  
              w' = w))"
  let ?ws = "λn. if n < length E' then ws' n else Eps (?P n)"
  
  have "n. n < length E'  ?ws n = ws' n" by simp
  moreover
  have "P  (E'', ?ws)   
        (n ad al v. n  read_actions E''  length E'  n  action_obs E'' n = NormalAction (ReadMem ad al v)  P,E''  ?ws n ≤hb n)"
  proof(intro conjI wf_execI strip is_write_seenI)
    fix a' ad al v
    assume read: "a'  read_actions E''" 
      and aobs: "action_obs E'' a' = NormalAction (ReadMem ad al v)"
    then obtain t where a': "enat a' < llength E''"
      and lnth'': "lnth E'' a' = (t, NormalAction (ReadMem ad al v))"
      by(cases)(cases "lnth E'' a'", clarsimp simp add: actions_def action_obs_def)

    have "?ws a'  write_actions E''  
      (ad, al)  action_loc P E'' (?ws a')  
      value_written P E'' (?ws a') (ad, al) = v 
      (length E'  a'  P,E''  ?ws a' ≤hb a') 
      ¬ P,E''  a' ≤hb ?ws a' 
      (is_volatile P al  ¬ P,E''  a' ≤so ?ws a') 
      (a''. a''  write_actions E''  (ad, al)  action_loc P E'' a'' 
             (P,E''  ?ws a' ≤hb a''  P,E''  a'' ≤hb a'  is_volatile P al  P,E''  ?ws a' ≤so a''  P,E''  a'' ≤so a')
              a'' = ?ws a')"
    proof(cases "a' < length E'", safe del: notI disjE conjE)
      assume a'_E': "a' < length E'"
      with read aobs have a': "a'  read_actions (llist_of E')" 
        and aobs': "action_obs (llist_of E') a' = NormalAction (ReadMem ad al v)"
        by(auto simp add: E''_def action_obs_def lnth_lappend1 actions_def elim: read_actions.cases intro: read_actions.intros)
      have sim: "ltake (enat (length E')) (llist_of E') [≈] ltake (enat (length E')) (lappend (llist_of E') E)"
        by(rule eq_into_sim_actions)(simp add: ltake_all ltake_lappend1)
      from tsa have tsa': "thread_start_actions_ok (llist_of E')"
        by(rule thread_start_actions_ok_prefix)(simp add: E''_def lprefix_lappend)

      from is_write_seenD[OF E'' a' aobs'] a'_E'
      show "?ws a'  write_actions E''"
        and "(ad, al)  action_loc P E'' (?ws a')"
        and "value_written P E'' (?ws a') (ad, al) = v"
        and "¬ P,E''  a' ≤hb ?ws a'"
        and "is_volatile P al  ¬ P,E''  a' ≤so ?ws a'"
        by(auto elim!: write_actions.cases intro!: write_actions.intros simp add: E''_def lnth_lappend1 actions_def action_obs_def value_written_def enat_less_enat_plusI dest: happens_before_change_prefix[OF _ tsa' sim[symmetric]] sync_order_change_prefix[OF _ sim[symmetric]])

      { assume "length E'  a'"
        thus "P,E''  ?ws a' ≤hb a'" using a'_E' by simp }

      { fix w
        assume w: "w  write_actions E''" "(ad, al)  action_loc P E'' w" 
          and hbso: "P,E''  ?ws a' ≤hb w  P,E''  w ≤hb a'  is_volatile P al  P,E''  ?ws a' ≤so w  P,E''  w ≤so a'"
        show "w = ?ws a'"
        proof(cases "w < length E'")
          case True
          with is_write_seenD[OF E'' a' aobs'] a'_E' w hbso show ?thesis
            by(auto 4 3 elim!: write_actions.cases intro!: write_actions.intros simp add: E''_def lnth_lappend1 actions_def action_obs_def value_written_def enat_less_enat_plusI dest: happens_before_change_prefix[OF _ tsa[unfolded E''_def] sim] happens_before_change_prefix[OF _ tsa' sim[symmetric]] sync_order_change_prefix[OF _ sim, simplified] sync_order_change_prefix[OF _ sim[symmetric], simplified] bspec[where x=w])
        next
          case False
          from hbso have "E''  w ≤a a'" by(auto intro: happens_before_into_action_order elim: sync_orderE)
          moreover from w(1) read have "w  a'" by(auto dest: read_actions_not_write_actions)
          ultimately have new_w: "is_new_action (action_obs E'' w)" using False aobs a'_E'
            by(cases rule: action_orderE) auto
          moreover from hbso a'_E' have "E''  ws' a' ≤a w"
            by(auto intro: happens_before_into_action_order elim: sync_orderE)
          hence new_a': "is_new_action (action_obs E'' (?ws a'))" using new_w a'_E'
            by(cases rule: action_orderE) auto
          ultimately have "w  new_actions_for P E'' (ad, al)" "?ws a'  new_actions_for P E'' (ad, al)"
            using w is_write_seenD[OF E'' a' aobs'] a'_E'
            by(auto simp add: new_actions_for_def actions_def action_obs_def lnth_lappend1 E''_def enat_less_enat_plusI elim!: write_actions.cases)
          thus ?thesis by(rule new_actions_for_fun)
        qed }
    next
      assume "¬ a' < length E'"
      hence a'_E': "length E'  a'" by simp
      define a where "a = a' - length E'"
      with a' a'_E' have a: "enat a < llength E"
        by(simp add: E''_def) (metis enat_add_mono le_add_diff_inverse plus_enat_simps(1))
      
      from a_def aobs lnth'' a'_E'
      have aobs: "action_obs E a = NormalAction (ReadMem ad al v)"
        and lnth: "lnth E a = (t, NormalAction (ReadMem ad al v))"
        by(simp_all add: E''_def lnth_lappend2 action_obs_def)
      
      define E''' where "E''' = lappend (llist_of E') (ltake (enat a) E)"
      let ?E'' = "lappend E''' (LCons (t, NormalAction (ReadMem ad al v)) LNil)"
    
      note hb also
      have E_unfold1: "E = lappend (ltake (enat a) E) (ldropn a E)" by simp
      also have E_unfold2: "ldropn a E = LCons (t, NormalAction (ReadMem ad al v)) (ldropn (Suc a) E)"
        using a lnth by (metis ldropn_Suc_conv_ldropn)
      finally
      have "ta_hb_consistent P (E' @ list_of (ltake (enat a) E))
              (LCons (t, NormalAction (ReadMem ad al v)) (ldropn (Suc a) E))"
        by(rule ta_hb_consistent_lappendD2) simp
      with a a'_E' a_def obtain w where w: "w  write_actions ?E''"
        and adal_w: "(ad, al)  action_loc P ?E'' w"
        and written: "value_written P ?E'' w (ad, al) = v"
        and hb: "P,?E''  w ≤hb a'"
        and in_between_so:
        "w'.  w'  write_actions ?E''; (ad, al)  action_loc P ?E'' w'; 
                is_volatile P al; P,?E''  w ≤so w'; P,?E''  w' ≤so a' 
         w' = w"        
        and in_between_hb: 
        "w'.  w'  write_actions ?E''; (ad, al)  action_loc P ?E'' w'; 
                P,?E''  w ≤hb w'; P,?E''  w' ≤hb a' 
         w' = w"
        by(auto simp add: ta_hb_consistent_LCons length_list_of_conv_the_enat min_def lnth_ltake lappend_llist_of_llist_of[symmetric] E'''_def lappend_assoc simp del: lappend_llist_of_llist_of nth_list_of split: if_splits)

      from a' a'_E' a
      have eq: "ltake (enat (Suc a')) ?E'' = ltake (enat (Suc a')) E''" (is "?lhs = ?rhs")
        unfolding E''_def E'''_def lappend_assoc
        apply(subst (2) E_unfold1)
        apply(subst E_unfold2)
        apply(subst (1 2) ltake_lappend2)
         apply(simp)
        apply(rule arg_cong) back
        apply(subst (1 2) ltake_lappend2)
         apply(simp add: min_def)
         apply (metis Suc_diff_le a_def le_Suc_eq order_le_less)
        apply(rule arg_cong) back
        apply(auto simp add: min_def a_def)
        apply(auto simp add: eSuc_enat[symmetric] zero_enat_def[symmetric])
        done
      hence sim: "?lhs [≈] ?rhs" by(rule eq_into_sim_actions)
      from tsa have tsa': "thread_start_actions_ok ?E''" unfolding E''_def E'''_def lappend_assoc
        by(rule thread_start_actions_ok_prefix)(subst (2) E_unfold1, simp add: E_unfold2)

      from w a a' a_def a'_E' have w_a': "w < Suc a'"
        by cases(simp add: actions_def E'''_def min_def zero_enat_def eSuc_enat split: if_split_asm)

      from w sim have "w  write_actions E''" by(rule write_actions_change_prefix)(simp add: w_a')
      moreover
      from adal_w action_loc_change_prefix[OF sim, of w P] w_a'
      have "(ad, al)  action_loc P E'' w" by simp
      moreover
      from written value_written_change_prefix[OF eq, of w P] w_a'
      have "value_written P E'' w (ad, al) = v" by simp
      moreover
      from hb tsa sim have "P,E''  w ≤hb a'" by(rule happens_before_change_prefix)(simp_all add: w_a')
      moreover {
        fix w'
        assume w': "w'  write_actions E''"
          and adal: "(ad, al)  action_loc P E'' w'"
          and hbso: "P,E''  w ≤hb w'  P,E''  w' ≤hb a'  is_volatile P al  P,E''  w ≤so w'  P,E''  w' ≤so a'"
          (is "?hbso E''")
        from hbso have ao: "E''  w ≤a w'" "E''  w' ≤a a'"
          by(auto dest: happens_before_into_action_order elim: sync_orderE)
        have "w' = w"
        proof(cases "is_new_action (action_obs E'' w')")
          case True
          hence "w'  new_actions_for P E'' (ad, al)" using w' adal by(simp add: new_actions_for_def)
          moreover from ao True have "is_new_action (action_obs E'' w)" by(cases rule: action_orderE) simp_all
          with w  write_actions E'' (ad, al)  action_loc P E'' w
          have "w  new_actions_for P E'' (ad, al)" by(simp add: new_actions_for_def)
          ultimately show "w' = w" by(rule new_actions_for_fun)
        next
          case False
          with ao have "w'  a'" by(auto elim: action_orderE)
          hence w'_a: "enat w' < enat (Suc a')" by simp
          with hbso w_a' have "?hbso ?E''"
            by(auto 4 3 elim: happens_before_change_prefix[OF _ tsa' sim[symmetric]] sync_order_change_prefix[OF _ sim[symmetric]] del: disjCI intro: disjI1 disjI2)
          moreover from w' w'  a' a' a lnth a'_E' have "w'  write_actions ?E''"
            by(cases)(cases "w' < a'", auto intro!: write_actions.intros simp add: E'''_def actions_def action_obs_def lnth_lappend min_def zero_enat_def eSuc_enat lnth_ltake a_def E''_def not_le not_less)
          moreover from adal w'  a' a a' lnth w' a'_E' have "(ad, al)  action_loc P ?E'' w'"
            by(cases "w' < a'")(cases "w' < length E'", auto simp add: E'''_def action_obs_def lnth_lappend lappend_assoc[symmetric] min_def lnth_ltake less_trans[where y="enat a"] a_def E''_def lnth_ltake elim: write_actions.cases)
          ultimately show "w' = w" by(blast dest: in_between_so in_between_hb)
        qed }
      ultimately have "?P a' w" using a'_E' lnth unfolding E''_def a_def by(simp add: lnth_lappend)
      hence P: "?P a' (Eps (?P a'))" by(rule someI[where P="?P a'"])
      
      from P lnth'' a'_E'
      show "?ws a'  write_actions E''" 
        and "(ad, al)  action_loc P E'' (?ws a')" 
        and "value_written P E'' (?ws a') (ad, al) = v" 
        and "P,E''  ?ws a' ≤hb a'" by simp_all

      show "¬ P,E''  a' ≤hb ?ws a'"
      proof
        assume "P,E''  a' ≤hb ?ws a'"
        with P,E''  ?ws a' ≤hb a' have "a' = ?ws a'"
          by(blast dest: antisymPD[OF antisym_action_order] happens_before_into_action_order)
        with read ?ws a'  write_actions E'' show False
          by(auto dest: read_actions_not_write_actions)
      qed

      show "¬ P,E''  a' ≤so ?ws a'"
      proof
        assume "P,E''  a' ≤so ?ws a'"
        hence "E''  a' ≤a ?ws a'" by(blast elim: sync_orderE)
        with P,E''  ?ws a' ≤hb a' have "a' = ?ws a'"
          by(blast dest: antisymPD[OF antisym_action_order] happens_before_into_action_order)
        with read ?ws a'  write_actions E'' show False
          by(auto dest: read_actions_not_write_actions)
      qed
      
      fix a''
      assume "a''  write_actions E''" "(ad, al)  action_loc P E'' a''"
        and "P,E''  ?ws a' ≤hb a''  P,E''  a'' ≤hb a' 
             is_volatile P al  P,E''  ?ws a' ≤so a''  P,E''  a'' ≤so a'"
      thus "a'' = ?ws a'" using lnth'' P a'_E' by -(erule disjE, clarsimp+)
    qed
    thus "?ws a'  write_actions E''"
      and "(ad, al)  action_loc P E'' (?ws a')"
      and "value_written P E'' (?ws a') (ad, al) = v"
      and "length E'  a'  P,E''  ?ws a' ≤hb a'"
      and "¬ P,E''  a' ≤hb ?ws a'"
      and "is_volatile P al  ¬ P,E''  a' ≤so ?ws a'"
      and "a''.  a''  write_actions E''; (ad, al)  action_loc P E'' a''; P,E''  ?ws a' ≤hb a''; P,E''  a'' ≤hb a'   a'' = ?ws a'"
      and "a''.  a''  write_actions E''; (ad, al)  action_loc P E'' a''; is_volatile P al; P,E''  ?ws a' ≤so a''; P,E''  a'' ≤so a'   a'' = ?ws a'"
      by blast+
  qed(assumption|rule tsa)+
  thus "P  (E'', ?ws) "
    and "n.  n  read_actions E''; length E'  n   P,E''  ?ws n ≤hb n"
    by(blast elim: read_actions.cases intro: read_actions.intros)+
  
  fix n
  assume "n < length E'"
  thus "?ws n = ws' n" by simp
qed

lemma ta_hb_consistent_not_ReadI:
  "(t ad al v. (t, NormalAction (ReadMem ad al v))  lset E)  ta_hb_consistent P E' E"
proof(coinduction arbitrary: E' E)
  case (ta_hb_consistent E' E)
  thus ?case by(cases E)(auto split: action.split obs_event.split, blast)
qed

context jmm_multithreaded begin

definition complete_hb :: "('l,'thread_id,'x,'m,'w) state  ('thread_id × ('addr, 'thread_id) obs_event action) list
   ('thread_id × ('l, 'thread_id, 'x, 'm, 'w, ('addr, 'thread_id) obs_event action) thread_action) llist"
where
  "complete_hb s E = unfold_llist
     (λ(s, E). t ta s'. ¬ s -tta s')
     (λ(s, E). fst (SOME ((t, ta), s'). s -tta s'  ta_hb_consistent P E (llist_of (map (Pair t) tao))))
     (λ(s, E). let ((t, ta), s') = SOME ((t, ta), s'). s -tta s'  ta_hb_consistent P E (llist_of (map (Pair t) tao))
         in (s', E @ map (Pair t) tao))
     (s, E)"

definition hb_completion ::
  "('l, 'thread_id, 'x, 'm, 'w) state  ('thread_id × ('addr, 'thread_id) obs_event action) list  bool"
where
  "hb_completion s E 
   (ttas s' t x ta x' m' i.
       s -▹ttas→* s'  
       non_speculative P (w_values P (λ_. {}) (map snd E)) (llist_of (concat (map (λ(t, ta). tao) ttas))) 
       thr s' t = (x, no_wait_locks)  t  (x, shr s') -ta (x', m')  actions_ok s' t ta 
       non_speculative P (w_values P (w_values P (λ_. {}) (map snd E)) (concat (map (λ(t, ta). tao) ttas))) (llist_of (take i tao)) 
       (ta' x'' m''. t  (x, shr s') -ta' (x'', m'')  actions_ok s' t ta'  
                      take i ta'o = take i tao 
                      ta_hb_consistent P
                        (E @ concat (map (λ(t, ta). map (Pair t) tao) ttas) @ map (Pair t) (take i tao))
                        (llist_of (map (Pair t) (drop i ta'o))) 
                      (i < length tao  i < length ta'o) 
                      (if ad al v. tao ! i = NormalAction (ReadMem ad al v) then sim_action else (=)) (tao ! i) (ta'o ! i)))"

lemma hb_completionD:
  " hb_completion s E; s -▹ttas→* s';
     non_speculative P (w_values P (λ_. {}) (map snd E)) (llist_of (concat (map (λ(t, ta). tao) ttas))); 
     thr s' t = (x, no_wait_locks); t  (x, shr s') -ta (x', m'); actions_ok s' t ta;
     non_speculative P (w_values P (w_values P (λ_. {}) (map snd E)) (concat (map (λ(t, ta). tao) ttas))) (llist_of (take i tao)) 
   ta' x'' m''. t  (x, shr s') -ta' (x'', m'')  actions_ok s' t ta' 
                   take i ta'o = take i tao 
                   ta_hb_consistent P (E @ concat (map (λ(t, ta). map (Pair t) tao) ttas) @ map (Pair t) (take i tao))
                                      (llist_of (map (Pair t) (drop i ta'o))) 
                   (i < length tao  i < length ta'o) 
                   (if ad al v. tao ! i = NormalAction (ReadMem ad al v) then sim_action else (=)) (tao ! i) (ta'o ! i)"
unfolding hb_completion_def by blast

lemma hb_completionI [intro?]:
  "(ttas s' t x ta x' m' i. 
      s -▹ttas→* s'; non_speculative P (w_values P (λ_. {}) (map snd E)) (llist_of (concat (map (λ(t, ta). tao) ttas)));
       thr s' t = (x, no_wait_locks); t  (x, shr s') -ta (x', m'); actions_ok s' t ta;
       non_speculative P (w_values P (w_values P (λ_. {}) (map snd E)) (concat (map (λ(t, ta). tao) ttas))) (llist_of (take i tao)) 
      ta' x'' m''. t  (x, shr s') -ta' (x'', m'')  actions_ok s' t ta'  take i ta'o = take i tao 
                   ta_hb_consistent P (E @ concat (map (λ(t, ta). map (Pair t) tao) ttas) @ map (Pair t) (take i tao)) (llist_of (map (Pair t) (drop i ta'o))) 
                   (i < length tao  i < length ta'o) 
                   (if ad al v. tao ! i = NormalAction (ReadMem ad al v) then sim_action else (=)) (tao ! i) (ta'o ! i))
   hb_completion s E"
unfolding hb_completion_def by blast

lemma hb_completion_shift:
  assumes hb_c: "hb_completion s E"
  and τRed: "s -▹ttas→* s'"
  and sc: "non_speculative P (w_values P (λ_. {}) (map snd E)) (llist_of (concat (map (λ(t, ta). tao) ttas)))"
      (is "non_speculative _ ?vs _")
  shows "hb_completion s' (E @ (concat (map (λ(t, ta). map (Pair t) tao) ttas)))"
  (is "hb_completion _ ?E")
proof(rule hb_completionI)
  fix ttas' s'' t x ta x' m' i
  assume τRed': "s' -▹ttas'→* s''"
    and sc': "non_speculative P (w_values P (λ_. {}) (map snd ?E)) (llist_of (concat (map (λ(t, ta). tao) ttas')))"
    and red: "thr s'' t = (x, no_wait_locks)" "t  x, shr s'' -ta x', m'" "actions_ok s'' t ta" 
    and ns: "non_speculative P (w_values P (w_values P (λ_. {}) (map snd ?E)) (concat (map (λ(t, ta). tao) ttas'))) (llist_of (take i tao))"
  from τRed τRed' have "s -▹ttas @ ttas'→* s''" unfolding RedT_def by(rule rtrancl3p_trans)
  moreover from sc sc' have "non_speculative P ?vs (llist_of (concat (map (λ(t, ta). tao) (ttas @ ttas'))))"
    unfolding map_append concat_append lappend_llist_of_llist_of[symmetric] map_concat
    by(simp add: non_speculative_lappend o_def split_def del: lappend_llist_of_llist_of)
  ultimately
  show "ta' x'' m''. t  x, shr s'' -ta' x'', m''  actions_ok s'' t ta'  take i ta'o = take i tao 
         ta_hb_consistent P (?E @ concat (map (λ(t, ta). map (Pair t) tao) ttas') @ map (Pair t) (take i tao))
                            (llist_of (map (Pair t) (drop i ta'o))) 
         (i < length tao  i < length ta'o) 
         (if ad al v. tao ! i = NormalAction (ReadMem ad al v) then sim_action else (=)) (tao ! i) (ta'o ! i)"
    using red ns unfolding append_assoc
    apply(subst (2) append_assoc[symmetric])
    unfolding concat_append[symmetric] map_append[symmetric] foldr_append[symmetric]
    by(rule hb_completionD[OF hb_c])(simp_all add: map_concat o_def split_def)
qed

lemma hb_completion_shift1:
  assumes hb_c: "hb_completion s E"
  and Red: "s -tta s'"
  and sc: "non_speculative P (w_values P (λ_. {}) (map snd E)) (llist_of tao)"
  shows "hb_completion s' (E @ map (Pair t) tao)"
using hb_completion_shift[OF hb_c, of "[(t, ta)]" s'] Red sc
by(simp add: RedT_def rtrancl3p_Cons rtrancl3p_Nil del: split_paired_Ex)

lemma complete_hb_in_Runs:
  assumes hb_c: "hb_completion s E"
  and ta_hb_consistent_convert_RA: "t E ln. ta_hb_consistent P E (llist_of (map (Pair t) (convert_RA ln)))"
  shows "mthr.Runs s (complete_hb s E)"
using hb_c
proof(coinduction arbitrary: s E)
  case (Runs s E)
  let ?P = "λ((t, ta), s'). s -tta s'  ta_hb_consistent P E (llist_of (map (Pair t) tao))"
  show ?case
  proof(cases "t ta s'. s -tta s'")
    case False
    then have ?Stuck by(simp add: complete_hb_def)
    thus ?thesis ..
  next
    case True
    let ?t = "fst (fst (Eps ?P))" and ?ta = "snd (fst (Eps ?P))" and ?s' = "snd (Eps ?P)"
    from True obtain t ta s' where red: "s -tta s'" by blast
    hence "x. ?P x"
    proof(cases)
      case (redT_normal x x' m')
      from hb_completionD[OF Runs _ _ ‹thr s t = (x, no_wait_locks) t  x, shr s -ta x', m' ‹actions_ok s t ta, of "[]" 0]
      obtain ta' x'' m'' where "t  x, shr s -ta' x'', m''"
        and "actions_ok s t ta'" "ta_hb_consistent P E (llist_of (map (Pair t) ta'o))" 
        by fastforce
      moreover obtain ws' where "redT_updWs t (wset s) ta'w ws'" by (metis redT_updWs_total)
      ultimately show ?thesis using ‹thr s t = (x, no_wait_locks)
        by(cases ta')(auto intro!: exI redT.redT_normal)
    next
      case (redT_acquire x n ln)
      thus ?thesis using ta_hb_consistent_convert_RA[of E t ln] 
        by(auto intro!: exI redT.redT_acquire)
    qed
    hence "?P (Eps ?P)" by(rule someI_ex)
    hence red: "s -?t?ta ?s'"
      and hb: "ta_hb_consistent P E (llist_of (map (Pair ?t) ?tao))"
      by(simp_all add: split_beta)
    moreover
    from ta_hb_consistent_into_non_speculative[OF hb]
    have "non_speculative P (w_values P (λ_. {}) (map snd E)) (llist_of ?tao)" by(simp add: o_def)
    with Runs red have "hb_completion ?s' (E @ map (Pair ?t) ?tao)" by(rule hb_completion_shift1)
    ultimately have ?Step using True
      unfolding complete_hb_def by(fastforce simp del: split_paired_Ex simp add: split_def)
    thus ?thesis ..
  qed
qed

lemma complete_hb_ta_hb_consistent:
  assumes "hb_completion s E"
  and ta_hb_consistent_convert_RA: "E t ln. ta_hb_consistent P E (llist_of (map (Pair t) (convert_RA ln)))"
  shows "ta_hb_consistent P E (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) (complete_hb s E)))"
  (is "ta_hb_consistent _ _ (?obs (complete_hb s E))")
proof -
  define obs a where "obs = ?obs (complete_hb s E)" and "a = complete_hb s E"
  with ‹hb_completion s E have "s. hb_completion s E  obs = ?obs (complete_hb s E)  a = complete_hb s E" by blast
  moreover have "wf (inv_image {(m, n). m < n} (llength  ltakeWhile (λ(t, ta). tao = [])))"
    (is "wf ?R") by(rule wf_inv_image)(rule wellorder_class.wf)
  ultimately show "ta_hb_consistent P E obs"
  proof(coinduct E obs a rule: ta_hb_consistent_coinduct_append_wf)
    case (ta_hb_consistent E obs a)
    then obtain s where hb_c: "hb_completion s E"
      and obs: "obs = lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) (complete_hb s E))"
      and a: "a = complete_hb s E"
      by blast
    let ?P = "λ((t, ta), s'). s -tta s'  ta_hb_consistent P E (llist_of (map (Pair t) tao))"
    show ?case
    proof(cases "t ta s'. s -tta s'")
      case False
      with obs have ?LNil by(simp add: complete_hb_def)
      thus ?thesis ..
    next
      case True
      let ?t = "fst (fst (Eps ?P))" and ?ta = "snd (fst (Eps ?P))" and ?s' = "snd (Eps ?P)"
      from True obtain t ta s' where red: "s -tta s'" by blast
      hence "x. ?P x"
      proof(cases)
        case (redT_normal x x' m')
        from hb_completionD[OF hb_c _ _ ‹thr s t = (x, no_wait_locks) t  x, shr s -ta x', m' ‹actions_ok s t ta, of "[]" 0]
        obtain ta' x'' m'' where "t  x, shr s -ta' x'', m''"
          and "actions_ok s t ta'" "ta_hb_consistent P E (llist_of (map (Pair t) ta'o))"
          by fastforce
        moreover obtain ws' where "redT_updWs t (wset s) ta'w ws'" by (metis redT_updWs_total)
        ultimately show ?thesis using ‹thr s t = (x, no_wait_locks)
          by(cases ta')(auto intro!: exI redT.redT_normal)
      next
        case (redT_acquire x n ln)
        thus ?thesis using ta_hb_consistent_convert_RA[of E t ln]
          by(auto intro!: exI redT.redT_acquire)
      qed
      hence "?P (Eps ?P)" by(rule someI_ex)
      hence red': "s -?t?ta ?s'" 
        and hb: "ta_hb_consistent P E (llist_of (map (Pair ?t) ?tao))"
        by(simp_all add: split_beta)
      moreover
      from ta_hb_consistent_into_non_speculative[OF hb]
      have "non_speculative P (w_values P (λ_. {}) (map snd E)) (llist_of ?tao)" by(simp add: o_def)
      with hb_c red' have hb_c': "hb_completion ?s' (E @ map (Pair ?t) ?tao)"
        by(rule hb_completion_shift1)
      show ?thesis
      proof(cases "lnull obs")
        case True thus ?thesis unfolding lnull_def by simp
      next
        case False
        have eq: "(t ta s'. ¬ s -tta s') = False" using True by auto
        { assume "?tao = []"
          moreover from obs False
          have "lfinite (ltakeWhile (λ(t, ta). tao = []) (complete_hb s E))"
            unfolding lfinite_ltakeWhile by(fastforce simp add: split_def lconcat_eq_LNil)
          ultimately have "(complete_hb ?s' (E @ map (Pair ?t) ?tao), a)  ?R"
            using red unfolding a complete_hb_def
            apply(subst (2) unfold_llist.code)
            apply(subst (asm) unfold_llist.code)
            apply(auto simp add: split_beta simp del: split_paired_Ex split_paired_All split: if_split_asm)
            apply(auto simp add: lfinite_eq_range_llist_of)
            done }
        hence ?lappend using red hb hb_c' unfolding obs complete_hb_def
          apply(subst unfold_llist.code)
          apply(simp add: split_beta eq del: split_paired_Ex split_paired_All split del: if_split)
          apply(intro exI conjI impI refl disjI1|rule refl|assumption|simp_all add: llist_of_eq_LNil_conv)+
          done
        thus ?thesis ..
      qed
    qed
  qed
qed

lemma hb_completion_Runs:
  assumes "hb_completion s E"
  and "E t ln. ta_hb_consistent P E (llist_of (map (Pair t) (convert_RA ln)))"
  shows "ttas. mthr.Runs s ttas  ta_hb_consistent P E (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) ttas))"
using complete_hb_in_Runs[OF assms] complete_hb_ta_hb_consistent[OF assms]
by blast

end

end


Theory JMM_Heap

(*  Title:      JinjaThreads/MM/JMM_Heap.thy
    Author:     Andreas Lochbihler
*)

section ‹Locales for heap operations with set of allocated addresses›

theory JMM_Heap 
imports
  "../Common/WellForm"
  SC_Completion
  HB_Completion
begin

definition w_addrs :: "('addr × addr_loc  'addr val set)  'addr set"
where "w_addrs vs = {a. adal. Addr a  vs adal}"

lemma w_addrs_empty [simp]: "w_addrs (λ_. {}) = {}"
by(simp add: w_addrs_def)

locale allocated_heap_base = heap_base +
  constrains addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  fixes allocated :: "'heap  'addr set"

locale allocated_heap = 
  allocated_heap_base +
  heap +
  constrains addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and allocated :: "'heap  'addr set"
  and P :: "'m prog"

  assumes allocated_empty: "allocated empty_heap = {}"
  and allocate_allocatedD:
  "(h', a)  allocate h hT  allocated h' = insert a (allocated h)  a  allocated h"
  and heap_write_allocated_same:
  "heap_write h a al v h'  allocated h' = allocated h"
begin

lemma allocate_allocated_mono: "(h', a)  allocate h C  allocated h  allocated h'"
by(simp_all add: allocate_allocatedD)

lemma
  shows start_addrs_allocated: "allocated start_heap = set start_addrs"
  and distinct_start_addrs': "distinct start_addrs"
proof -
  { fix h ads b and xs :: "cname list"
    let "?start_addrs h ads b xs" = "fst (snd (foldl create_initial_object (h, ads, b) xs))"
    let "?start_heap h ads b xs" = "fst (foldl create_initial_object (h, ads, b) xs)"
    assume "allocated h = set ads"
    hence "allocated (?start_heap h ads b xs) = set (?start_addrs h ads b xs) 
           (distinct ads  distinct (?start_addrs h ads b xs))"
      (is "?concl xs h ads b")
    proof(induct xs arbitrary: h ads b)
      case Nil thus ?case by auto
    next
      case (Cons x xs)
      note ads = allocated h = set ads
      show ?case
      proof(cases "b  allocate h (Class_type x)  {}")
        case False thus ?thesis using ads
          by(simp add: create_initial_object_simps zip_append1)
      next
        case [simp]: True
        then obtain h' a' 
          where h'a': "(SOME ha. ha  allocate h (Class_type x)) = (h', a')"
          and new_obj: "(h', a')  allocate h (Class_type x)"
          by(cases "(SOME ha. ha  allocate h (Class_type x))")(auto simp del: True dest: allocate_Eps)

        from new_obj have "allocated h' = insert a' (allocated h)" "a'  allocated h"
          by(auto dest: allocate_allocatedD)
        with ads have "allocated h' = set (ads @ [a'])" by auto
        hence "?concl xs h' (ads @ [a']) True" by(rule Cons)
        moreover have "a'  set ads" using a'  allocated h ads by blast
        ultimately show ?thesis by(simp add: create_initial_object_simps new_obj h'a')
      qed
    qed }
  from this[of empty_heap "[]" True initialization_list]
  show "allocated start_heap = set start_addrs"
    and distinct_start_addrs: "distinct start_addrs"
    unfolding start_heap_def start_addrs_def start_heap_data_def
    by(auto simp add: allocated_empty)
qed

lemma w_addrs_start_heap_obs: "w_addrs (w_values P vs (map NormalAction start_heap_obs))  w_addrs vs"
proof -
  { fix xs
    let ?NewObj = "λa C. NewHeapElem a (Class_type C) :: ('addr, 'thread_id) obs_event"
    let "?start_heap_obs xs" = "map (λ(C, a). ?NewObj a C) xs"
    have "w_addrs (w_values P vs (map NormalAction (?start_heap_obs xs)))  w_addrs vs"
      (is "?concl xs")
    proof(induct xs arbitrary: vs)
      case Nil thus ?case by simp
    next
      case (Cons x xs)
      have "w_addrs (w_values P vs (map NormalAction (map (λ(C, a). ?NewObj a C) (x # xs))))
        = w_addrs (w_values P (w_value P vs (NormalAction (?NewObj (snd x) (fst x)))) (map NormalAction (map (λ(C, a). ?NewObj a C) xs)))"
        by(simp add: split_beta)
      also have "  w_addrs (w_value P vs (NormalAction (?NewObj (snd x) (fst x))))" by(rule Cons)
      also have "  w_addrs vs"
        by(auto simp add: w_addrs_def default_val_not_Addr Addr_not_default_val)
      finally show ?case .
    qed }
  thus ?thesis by(simp add: start_heap_obs_def)
qed

end

context heap_base begin

lemma addr_loc_default_conf:
  "P  class_type_of CTn has F:T (fm) in C 
   P,h  addr_loc_default P CTn (CField C F) :≤ T"
apply(cases CTn)
 apply simp
apply(frule has_field_decl_above)
apply simp
done

definition vs_conf :: "'m prog  'heap  ('addr × addr_loc  'addr val set)  bool"
where "vs_conf P h vs  (ad al v. v  vs (ad, al)  (T. P,h  ad@al : T  P,h  v :≤ T))"

lemma vs_confI:
  "(ad al v. v  vs (ad, al)  T. P,h  ad@al : T  P,h  v :≤ T)  vs_conf P h vs"
unfolding vs_conf_def by blast

lemma vs_confD:
  " vs_conf P h vs; v  vs (ad, al)   T. P,h  ad@al : T  P,h  v :≤ T"
unfolding vs_conf_def by blast

lemma vs_conf_insert_iff:
  "vs_conf P h (vs((ad, al) := insert v (vs (ad, al)))) 
   vs_conf P h vs  (T. P,h  ad@al : T  P,h  v :≤ T)"
by(auto 4 3 elim: vs_confD intro: vs_confI split: if_split_asm)

end

context heap begin

lemma vs_conf_hext: " vs_conf P h vs; h  h'   vs_conf P h' vs"
by(blast intro!: vs_confI intro: conf_hext addr_loc_type_hext_mono dest: vs_confD)

lemma vs_conf_allocate:
  " vs_conf P h vs; (h', a)  allocate h hT; is_htype P hT  
   vs_conf P h' (w_value P vs (NormalAction (NewHeapElem a hT)))"
apply(drule vs_conf_hext)
 apply(erule hext_allocate)
apply(auto intro!: vs_confI simp add: addr_locs_def split: if_split_asm htype.split_asm)
apply(auto 3 3 intro: addr_loc_type.intros defval_conf dest: allocate_SomeD elim: has_field_is_class vs_confD)
apply(rule exI conjI addr_loc_type.intros|drule allocate_SomeD|erule has_field_is_class|simp)+
done

end

text heap_read_typeable› must not be defined in @{term heap_conf_base} (where it should be) because
  this would lead to duplicate definitions of heap_read_typeable› in contexts where @{term heap_conf_base} 
  is imported twice with different parameters, e.g., @{term P} and @{term "J2JVM P"} in @{term "J_JVM_heap_conf_read"}.
›

context heap_base begin

definition heap_read_typeable :: "('heap  bool)  'm prog  bool"
where "heap_read_typeable hconf P  (h ad al v T. hconf h  P,h  ad@al : T  P,h  v :≤ T  heap_read h ad al v)"

lemma heap_read_typeableI:
  "(h ad al v T.  P,h  ad@al : T; P,h  v :≤ T; hconf h   heap_read h ad al v)  heap_read_typeable hconf P"
unfolding heap_read_typeable_def by blast

lemma heap_read_typeableD:
  " heap_read_typeable hconf P; P,h  ad@al : T; P,h  v :≤ T; hconf h   heap_read h ad al v"
unfolding heap_read_typeable_def by blast

end

context heap_base begin

definition heap_read_typed :: "'m prog  'heap  'addr  addr_loc  'addr val  bool"
where "heap_read_typed P h ad al v  heap_read h ad al v  (T. P,h  ad@al : T  P,h  v :≤ T)"

lemma heap_read_typedI:
  " heap_read h ad al v; T. P,h  ad@al : T  P,h  v :≤ T   heap_read_typed P h ad al v"
unfolding heap_read_typed_def by blast

lemma heap_read_typed_into_heap_read:
  "heap_read_typed P h ad al v  heap_read h ad al v"
unfolding heap_read_typed_def by blast

lemma heap_read_typed_typed:
  " heap_read_typed P h ad al v; P,h  ad@al : T   P,h  v :≤ T"
unfolding heap_read_typed_def by blast

end

context heap_conf begin

lemma heap_conf_read_heap_read_typed:
  "heap_conf_read addr2thread_id thread_id2addr empty_heap allocate typeof_addr (heap_read_typed P) heap_write hconf P"
proof
  fix h a al v T
  assume "heap_read_typed P h a al v" "P,h  a@al : T" 
  thus "P,h  v :≤ T" by(rule heap_read_typed_typed)
qed

end

context heap begin

lemma start_addrs_dom_w_values:
  assumes wf: "wf_syscls P"
  and a: "a  set start_addrs"
  and adal: "P,start_heap  a@al : T"
  shows "w_values P (λ_. {}) (map NormalAction start_heap_obs) (a, al)  {}"
proof -
  from a obtain CTn where CTn: "NewHeapElem a CTn  set start_heap_obs"
    unfolding in_set_start_addrs_conv_NewHeapElem ..
  then obtain obs obs' where obs: "start_heap_obs = obs @ NewHeapElem a CTn # obs'" by(auto dest: split_list)
  have "w_value P (w_values P (λ_. {}) (map NormalAction obs)) (NormalAction (NewHeapElem a CTn)) (a, al)  {}"
  proof(cases CTn)
    case [simp]: (Class_type C)
    with wf CTn have "typeof_addr start_heap a = Class_type C"
      by(auto intro: NewHeapElem_start_heap_obsD)
    with adal show ?thesis by cases auto
  next
    case [simp]: (Array_type T n)
    with wf CTn have "typeof_addr start_heap a = Array_type T n"
      by(auto dest: NewHeapElem_start_heap_obsD)
    with adal show ?thesis by cases(auto dest: has_field_decl_above)
  qed
  moreover have "w_value P (w_values P (λ_. {}) (map NormalAction obs)) (NormalAction (NewHeapElem a CTn :: ('addr, 'thread_id) obs_event))
    (a, al)  w_values P (λ_. {}) (map NormalAction start_heap_obs) (a, al)"
    by(simp add: obs del: w_value.simps)(rule w_values_mono)
  ultimately show ?thesis by blast
qed

end

end

Theory JMM_Framework

(*  Title:      JinjaThreads/MM/JMM_Framework.thy
    Author:     Andreas Lochbihler
*)

section ‹Combination of locales for heap operations and interleaving›

theory JMM_Framework
imports
  JMM_Heap
  "../Framework/FWInitFinLift"
  "../Common/WellForm"
begin

lemma enat_plus_eq_enat_conv: ― ‹Move to Extended\_Nat›
  "enat m + n = enat k  k  m  n = enat (k - m)"
by(cases n) auto

declare convert_new_thread_action_id [simp]

context heap begin

lemma init_fin_lift_state_start_state:
  "init_fin_lift_state s (start_state f P C M vs) = start_state (λC M Ts T meth vs. (s, f C M Ts T meth vs)) P C M vs"
by(simp add: start_state_def init_fin_lift_state_def split_beta fun_eq_iff)

lemma non_speculative_start_heap_obs:
  "non_speculative P vs  (llist_of (map snd (lift_start_obs start_tid start_heap_obs)))"
apply(rule non_speculative_nthI)
using start_heap_obs_not_Read
by(clarsimp simp add: lift_start_obs_def lnth_LCons o_def eSuc_enat[symmetric] in_set_conv_nth split: nat.split_asm)

lemma ta_seq_consist_start_heap_obs:
  "ta_seq_consist P Map.empty (llist_of (map snd (lift_start_obs start_tid start_heap_obs)))"
using start_heap_obs_not_Read
by(auto intro: ta_seq_consist_nthI simp add: lift_start_obs_def o_def lnth_LCons in_set_conv_nth split: nat.split_asm)

end

context allocated_heap begin

lemma w_addrs_lift_start_heap_obs:
  "w_addrs (w_values P vs (map snd (lift_start_obs start_tid start_heap_obs)))  w_addrs vs"
by(simp add: lift_start_obs_def o_def w_addrs_start_heap_obs)

end

context heap begin

lemma w_values_start_heap_obs_typeable:
  assumes wf: "wf_syscls P"
  and mrws: "v  w_values P (λ_. {}) (map snd (lift_start_obs start_tid start_heap_obs)) (ad, al)"
  shows "T. P,start_heap  ad@al : T  P,start_heap  v :≤ T"
proof -
  from in_w_valuesD[OF mrws]
  obtain obs' wa obs'' 
    where eq: "map snd (lift_start_obs start_tid start_heap_obs) = obs' @ wa # obs''"
    and "is_write_action wa"
    and adal: "(ad, al)  action_loc_aux P wa"
    and vwa: "value_written_aux P wa al = v"
    by blast
  from ‹is_write_action wa show ?thesis
  proof cases
    case (WriteMem ad' al' v')
    with vwa adal eq have "WriteMem ad al v  set start_heap_obs"
      by(auto simp add: map_eq_append_conv Cons_eq_append_conv lift_start_obs_def)
    thus ?thesis by(rule start_heap_write_typeable)
  next
    case (NewHeapElem ad' hT)
    with vwa adal eq have "NewHeapElem ad hT  set start_heap_obs"
      by(auto simp add: map_eq_append_conv Cons_eq_append_conv lift_start_obs_def)
    hence "typeof_addr start_heap ad = hT"
      by(rule NewHeapElem_start_heap_obsD[OF wf])
    thus ?thesis using adal vwa NewHeapElem
      apply(cases hT)
      apply(auto intro!: addr_loc_type.intros dest: has_field_decl_above)
      apply(frule has_field_decl_above)
      apply(auto intro!: addr_loc_type.intros dest: has_field_decl_above)
      done
  qed
qed

lemma start_state_vs_conf:
  "wf_syscls P  vs_conf P start_heap (w_values P (λ_. {}) (map snd (lift_start_obs start_tid start_heap_obs)))"
by(rule vs_confI)(rule w_values_start_heap_obs_typeable)

end


subsection ‹JMM traces for Jinja semantics›

context multithreaded_base begin

inductive_set  :: "('l,'t,'x,'m,'w) state  ('t × 'o) llist set"
  for σ :: "('l,'t,'x,'m,'w) state"
where
  "mthr.Runs σ E'
   lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E')   σ"

lemma actions_ℰE_aux:
  fixes σ E'
  defines "E == lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E')"
  assumes mthr: "mthr.Runs σ E'"
  and a: "enat a < llength E"
  obtains m n t ta
  where "lnth E a = (t, tao ! n)"
  and "n < length tao" and "enat m < llength E'"
  and "a = (i<m. length snd (lnth E' i)o) + n"
  and "lnth E' m = (t, ta)"
proof -
  from lnth_lconcat_conv[OF a[unfolded E_def], folded E_def]
  obtain m n
    where "lnth E a = lnth (lnth (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E') m) n"
    and "enat n < llength (lnth (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E') m)"
    and "enat m < llength (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E')"
    and "enat a = (i<m. llength (lnth (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E') i)) + enat n"
    by blast
  moreover
  obtain t ta where "lnth E' m = (t, ta)" by(cases "lnth E' m")
  ultimately have E_a: "lnth E a = (t, tao ! n)"
    and n: "n < length tao"
    and m: "enat m < llength E'"
    and a: "enat a = (i<m. llength (lnth (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E') i)) + enat n"
    by(simp_all add: lnth_llist_of)
  note a
  also have "(i<m. llength (lnth (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E') i)) = 
            sum (enat  (λi. length snd (lnth E' i)o)) {..<m}"
    using m by(simp add: less_trans[where y="enat m"] split_beta)
  also have " = enat (i<m. length snd (lnth E' i)o)"
    by(subst sum_hom)(simp_all add: zero_enat_def)
  finally have a: "a = (i<m. length snd (lnth E' i)o) + n" by simp
  with E_a n m show thesis using ‹lnth E' m = (t, ta) by(rule that)
qed

lemma actions_ℰE:
  assumes E: "E σ"
  and a: "enat a < llength E"
  obtains E' m n t ta
  where "E = lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E')"
  and "mthr.Runs σ E'"
  and "lnth E a = (t, tao ! n)"
  and "n < length tao" and "enat m < llength E'"
  and "a = (i<m. length snd (lnth E' i)o) + n"
  and "lnth E' m = (t, ta)"
proof -
  from E obtain E' ws
    where E: "E = lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E')"
    and "mthr.Runs σ E'" by(rule ℰ.cases) blast
  from ‹mthr.Runs σ E' a[unfolded E]
  show ?thesis
    by(rule actions_ℰE_aux)(fold E, rule that[OF E ‹mthr.Runs σ E'])
qed

end

context τmultithreaded_wf begin

text ‹Alternative characterisation for @{term "ℰ"}
lemma ℰ_conv_Runs:
  "ℰ σ = lconcat ` lmap (λ(t, ta). llist_of (map (Pair t) tao)) ` llist_of_tllist ` {E. mthr.τRuns σ E}"
  (is "?lhs = ?rhs")
proof(intro equalityI subsetI)
  fix E
  assume "E  ?rhs"
  then obtain E' where E: "E = lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) (llist_of_tllist E'))"
    and τRuns: "mthr.τRuns σ E'" by(blast)
  obtain E'' where E': "E' = tmap (λ(tls, s', tl, s''). tl) (case_sum (λ(tls, s'). s') Map.empty) E''"
    and τRuns': "mthr.τRuns_table2 σ E''"
    using τRuns by(rule mthr.τRuns_into_τRuns_table2)
  have "mthr.Runs σ (lconcat (lappend (lmap (λ(tls, s, tl, s'). llist_of (tls @ [tl])) (llist_of_tllist E'')) 
                                      (LCons (case terminal E'' of Inl (tls, s')  llist_of tls | Inr tls  tls) LNil)))"
    (is "mthr.Runs _ ?E'''")
    using τRuns' by(rule mthr.τRuns_table2_into_Runs)
  moreover 
  let ?tail = "λE''. case terminal E'' of Inl (tls, s')  llist_of tls | Inr tls  tls"
  {
    have "E = lconcat (lfilter (λxs. ¬ lnull xs) (lmap (λ(t, ta). llist_of (map (Pair t) tao)) (llist_of_tllist E')))"
      unfolding E by(simp add: lconcat_lfilter_neq_LNil)
    also have " = lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) (lmap (λ(tls, s', tta, s''). tta) (lfilter (λ(tls, s', (t, ta), s''). tao  []) (llist_of_tllist E''))))"
      by(simp add: E' lfilter_lmap llist.map_comp o_def split_def)
    also
    from ‹mthr.τRuns_table2 σ E''
    have "lmap (λ(tls, s', tta, s''). tta) (lfilter (λ(tls, s', (t, ta), s''). tao  []) (llist_of_tllist E'')) = 
          lfilter (λ(t, ta). tao  []) (lconcat (lappend (lmap (λ(tls, s, tl, s'). llist_of (tls @ [tl])) (llist_of_tllist E'')) (LCons (?tail E'') LNil)))"
      (is "?lhs σ E'' = ?rhs σ E''")
    proof(coinduction arbitrary: σ E'' rule: llist.coinduct_strong)
      case (Eq_llist σ E'')
      have ?lnull
        by(cases "lfinite (llist_of_tllist E'')")(fastforce split: sum.split_asm simp add: split_beta lset_lconcat_lfinite lappend_inf mthr.silent_move2_def dest: mthr.τRuns_table2_silentsD[OF Eq_llist] mthr.τRuns_table2_terminal_silentsD[OF Eq_llist] mthr.τRuns_table2_terminal_inf_stepD[OF Eq_llist] mτmove_silentD inf_step_silentD silent_moves2_silentD split: sum.split_asm)+
      moreover
      have ?LCons
      proof(intro impI conjI)
        assume lhs': "¬ lnull (lmap (λ(tls, s', tta, s''). tta) (lfilter (λ(tls, s', (t, ta), s''). tao  []) (llist_of_tllist E'')))"
          (is "¬ lnull ?lhs'")
          and "¬ lnull (lfilter (λ(t, ta). tao  []) (lconcat (lappend (lmap (λ(tls, s, tl, s'). llist_of (tls @ [tl])) (llist_of_tllist E'')) (LCons (case terminal E'' of Inl (tls, s')  llist_of tls | Inr tls  tls) LNil))))"
          (is "¬ lnull ?rhs'")

        note τRuns' = ‹mthr.τRuns_table2 σ E''
        from lhs' obtain tl tls' where "?lhs σ E'' = LCons tl tls'"
          by(auto simp only: not_lnull_conv)
        then obtain tls s' s'' tlsstlss'
          where tls': "tls' = lmap (λ(tls, s', tta, s''). tta) tlsstlss'"
          and filter: "lfilter (λ(tls, s', (t, ta), s''). obs_a ta  []) (llist_of_tllist E'') = LCons (tls, s', tl, s'') tlsstlss'"
          using lhs' by(fastforce simp add: lmap_eq_LCons_conv)
        from lfilter_eq_LConsD[OF filter]
        obtain us vs where eq: "llist_of_tllist E'' = lappend us (LCons (tls, s', tl, s'') vs)"
          and fin: "lfinite us"
          and empty: "(tls, s', (t, ta), s'')lset us. obs_a ta = []"
          and neq_empty: "obs_a (snd tl)  []"
          and tlsstlss': "tlsstlss' = lfilter (λ(tls, s', (t, ta), s''). obs_a ta  []) vs"
          by(auto simp add: split_beta)
        from eq obtain E''' where E'': "E'' = lappendt us E'''" 
          and eq': "llist_of_tllist E''' = LCons (tls, s', tl, s'') vs"
          and terminal: "terminal E''' = terminal E''"
          unfolding llist_of_tllist_eq_lappend_conv by auto
        from τRuns' fin E'' obtain σ' where τRuns'': "mthr.τRuns_table2 σ' E'''"
          by(auto dest: mthr.τRuns_table2_lappendtD)
        then obtain σ'' E'''' where "mthr.τRuns_table2 σ'' E''''" "E''' = TCons (tls, s', tl, s'') E''''"
          using eq' by cases auto
        moreover from τRuns' E'' fin
        have "(tls, s, tl, s')lset us. (t, ta)set tls. ta = ε"
          by(fastforce dest: mthr.τRuns_table2_silentsD mτmove_silentD simp add: mthr.silent_move2_def)
        hence "lfilter (λ(t, ta). obs_a ta  []) (lconcat (lmap (λ(tls, s, tl, s'). llist_of (tls @ [tl])) us)) = LNil"
          using empty by(auto simp add: lfilter_empty_conv lset_lconcat_lfinite split_beta)
        moreover from τRuns'' eq' have "snd ` set tls  {ε}"
          by(cases)(fastforce dest: silent_moves2_silentD)+
        hence "[(t, ta)tls . obs_a ta  []] = []"
          by(auto simp add: filter_empty_conv split_beta)
        ultimately 
        show "lhd ?lhs' = lhd ?rhs'"
          and "(σ E''. ltl ?lhs' = lmap (λ(tls, s', tta, s''). tta) (lfilter (λ(tls, s', (t, ta), s''). tao  []) (llist_of_tllist E'')) 
           ltl ?rhs' = lfilter (λ(t, ta). tao  []) (lconcat (lappend (lmap (λ(tls, s, tl, s'). llist_of (tls @ [tl])) (llist_of_tllist E'')) (LCons (case terminal E'' of Inl (tls, s')  llist_of tls | Inr tls  tls) LNil))) 
           τtrsys.τRuns_table2 redT mτmove σ E'') 
          ltl ?lhs' = ltl ?rhs'"
          using lhs' E'' fin tls' tlsstlss' filter eq' neq_empty
          by(auto simp add: lmap_lappend_distrib lappend_assoc split_beta filter_empty_conv simp del: split_paired_Ex)
      qed
      ultimately show ?case ..
    qed
    also have "lmap (λ(t, ta). llist_of (map (Pair t) (obs_a ta)))  = lfilter (λobs. ¬ lnull obs) (lmap (λ(t, ta). llist_of (map (Pair t) (obs_a ta))) (lconcat (lappend (lmap (λ(tls, s, tl, s'). llist_of (tls @ [tl])) (llist_of_tllist E'')) (LCons (?tail E'') LNil))))"
      unfolding lfilter_lmap by(simp add: o_def split_def llist_of_eq_LNil_conv)
    finally have "E = lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) ?E''')"
      by(simp add: lconcat_lfilter_neq_LNil) }
  ultimately show "E  ?lhs" by(blast intro: ℰ.intros)
next
  fix E
  assume "E  ?lhs"
  then obtain E' where E: "E = lconcat (lmap (λ(t, ta). llist_of (map (Pair t) (obs_a ta))) E')"
    and Runs: "mthr.Runs σ E'" by(blast elim: ℰ.cases)
  from Runs obtain E'' where E': "E' = lmap (λ(s, tl, s'). tl) E''"
    and Runs': "mthr.Runs_table σ E''" by(rule mthr.Runs_into_Runs_table)
  have "mthr.τRuns σ (tmap (λ(s, tl, s'). tl) id (tfilter None (λ(s, tl, s'). ¬ mτmove s tl s') (tllist_of_llist (Some (llast (LCons σ (lmap (λ(s, tl, s'). s') E'')))) E'')))"
    (is "mthr.τRuns _ ?E'''")
    using Runs' by(rule mthr.Runs_table_into_τRuns)
  moreover
  have "(λ(s, (t, ta), s'). obs_a ta  []) = (λ(s, (t, ta), s'). obs_a ta  []  ¬ mτmove s (t, ta) s')"
    by(rule ext)(auto dest: mτmove_silentD)
  hence "E = lconcat (lmap (λ(t, ta). llist_of (map (Pair t) (obs_a ta))) (llist_of_tllist ?E'''))"
    unfolding E E'
    by(subst (1 2) lconcat_lfilter_neq_LNil[symmetric])(simp add: lfilter_lmap lfilter_lfilter o_def split_def)
  ultimately show "E  ?rhs" by(blast)
qed

end

text ‹Running threads have been started before›

definition Status_no_wait_locks :: "('l,'t,status × 'x) thread_info  bool"
where
  "Status_no_wait_locks ts  
  (t status x ln. ts t = ((status, x), ln)  status  Running  ln = no_wait_locks)"

lemma Status_no_wait_locks_PreStartD:
  "ln.  Status_no_wait_locks ts; ts t = ((PreStart, x), ln)   ln = no_wait_locks"
unfolding Status_no_wait_locks_def by blast

lemma Status_no_wait_locks_FinishedD:
  "ln.  Status_no_wait_locks ts; ts t = ((Finished, x), ln)   ln = no_wait_locks"
unfolding Status_no_wait_locks_def by blast

lemma Status_no_wait_locksI:
  "(t status x ln.  ts t = ((status, x), ln); status = PreStart  status = Finished   ln = no_wait_locks)
   Status_no_wait_locks ts"
unfolding Status_no_wait_locks_def 
apply clarify
apply(case_tac status)
apply auto
done

context heap_base begin

lemma Status_no_wait_locks_start_state:
  "Status_no_wait_locks (thr (init_fin_lift_state status (start_state f P C M vs)))"
by(clarsimp simp add: Status_no_wait_locks_def init_fin_lift_state_def start_state_def split_beta)

end

context multithreaded_base begin

lemma init_fin_preserve_Status_no_wait_locks:
  assumes ok: "Status_no_wait_locks (thr s)"
  and redT: "multithreaded_base.redT init_fin_final init_fin (map NormalAction  convert_RA) s tta s'"
  shows "Status_no_wait_locks (thr s')"
using redT
proof(cases rule: multithreaded_base.redT.cases[consumes 1, case_names redT_normal redT_acquire])
  case redT_acquire
  with ok show ?thesis
    by(auto intro!: Status_no_wait_locksI dest: Status_no_wait_locks_PreStartD Status_no_wait_locks_FinishedD split: if_split_asm)
next
  case redT_normal
  show ?thesis
  proof(rule Status_no_wait_locksI)
    fix t' status' x' ln'
    assume tst': "thr s' t' = ((status', x'), ln')"
      and status: "status' = PreStart  status' = Finished"
    show "ln' = no_wait_locks"
    proof(cases "thr s t'")
      case None
      with redT_normal tst' show ?thesis
        by(fastforce elim!: init_fin.cases dest: redT_updTs_new_thread simp add: final_thread.actions_ok_iff split: if_split_asm)
    next
      case (Some sxln)
      obtain status'' x'' ln'' 
        where [simp]: "sxln = ((status'', x''), ln'')" by(cases sxln) auto
      show ?thesis
      proof(cases "fst tta = t'")
        case True
        with redT_normal tst' status show ?thesis by(auto simp add: expand_finfun_eq fun_eq_iff)
      next
        case False
        with tst' redT_normal Some status have "status'' = status'" "ln'' = ln'" 
          by(force dest: redT_updTs_Some simp add: final_thread.actions_ok_iff)+
        with ok Some status show ?thesis
          by(auto dest: Status_no_wait_locks_PreStartD Status_no_wait_locks_FinishedD)
      qed
    qed
  qed
qed

lemma init_fin_Running_InitialThreadAction:
  assumes redT: "multithreaded_base.redT init_fin_final init_fin (map NormalAction  convert_RA) s tta s'"
  and not_running: "x ln. thr s t  ((Running, x), ln)"
  and running: "thr s' t = ((Running, x'), ln')"
  shows "tta = (t, InitialThreadAction)"
using redT
proof(cases rule: multithreaded_base.redT.cases[consumes 1, case_names redT_normal redT_acquire])
  case redT_acquire
  with running not_running show ?thesis by(auto split: if_split_asm)
next
  case redT_normal
  show ?thesis
  proof(cases "thr s t")
    case None
    with redT_normal running not_running show ?thesis
      by(fastforce simp add: final_thread.actions_ok_iff elim: init_fin.cases dest: redT_updTs_new_thread split: if_split_asm)
  next
    case (Some a)
    with redT_normal running not_running show ?thesis
      apply(cases a)
      apply(auto simp add: final_thread.actions_ok_iff split: if_split_asm elim: init_fin.cases)
      apply((drule (1) redT_updTs_Some)?, fastforce)+
      done
  qed
qed

end

context if_multithreaded begin

lemma init_fin_Trsys_preserve_Status_no_wait_locks:
  assumes ok: "Status_no_wait_locks (thr s)"
  and Trsys: "if.mthr.Trsys s ttas s'"
  shows "Status_no_wait_locks (thr s')"
using Trsys ok
by(induct)(blast dest: init_fin_preserve_Status_no_wait_locks)+

lemma init_fin_Trsys_Running_InitialThreadAction:
  assumes redT: "if.mthr.Trsys s ttas s'"
  and not_running: "x ln. thr s t  ((Running, x), ln)"
  and running: "thr s' t = ((Running, x'), ln')"
  shows "(t, InitialThreadAction)  set ttas"
using redT not_running running
proof(induct arbitrary: x' ln')
  case rtrancl3p_refl thus ?case by(fastforce)
next
  case (rtrancl3p_step s ttas s' tta s'') thus ?case
    by(cases "x ln. thr s' t = ((Running, x), ln)")(fastforce dest: init_fin_Running_InitialThreadAction)+
qed

end

locale heap_multithreaded_base =
  heap_base
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write 
  +
  mthr: multithreaded_base final r convert_RA
  for addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool" 
  and final :: "'x  bool"
  and r :: "('addr, 'thread_id, 'x, 'heap, 'addr, ('addr, 'thread_id) obs_event) semantics" ("_  _ -_ _" [50,0,0,50] 80) 
  and convert_RA :: "'addr released_locks  ('addr, 'thread_id) obs_event list"

sublocale heap_multithreaded_base < mthr: if_multithreaded_base final r convert_RA
.

context heap_multithreaded_base begin

abbreviation ℰ_start ::
  "(cname  mname  ty list  ty  'md  'addr val list  'x) 
   'md prog  cname  mname  'addr val list  status 
   ('thread_id × ('addr, 'thread_id) obs_event action) llist set"
where
  "ℰ_start f P C M vs status  
  lappend (llist_of (lift_start_obs start_tid start_heap_obs)) ` 
  mthr.if.ℰ (init_fin_lift_state status (start_state f P C M vs))"

end

locale heap_multithreaded =
  heap_multithreaded_base 
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write
    final r convert_RA
  +
  heap
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write 
    P 
  + 
  mthr: multithreaded final r convert_RA

  for addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool" 
  and final :: "'x  bool"
  and r :: "('addr, 'thread_id, 'x, 'heap, 'addr, ('addr, 'thread_id) obs_event) semantics" ("_  _ -_ _" [50,0,0,50] 80) 
  and convert_RA :: "'addr released_locks  ('addr, 'thread_id) obs_event list" 
  and P :: "'md prog"

sublocale heap_multithreaded < mthr: if_multithreaded final r convert_RA
by(unfold_locales)

sublocale heap_multithreaded < "if": jmm_multithreaded
  mthr.init_fin_final mthr.init_fin "map NormalAction  convert_RA" P
.

context heap_multithreaded begin

lemma thread_start_actions_ok_init_fin_RedT:
  assumes Red: "mthr.if.RedT (init_fin_lift_state status (start_state f P C M vs)) ttas s'"
           (is "mthr.if.RedT ?start_state _ _")
  shows "thread_start_actions_ok (llist_of (lift_start_obs start_tid start_heap_obs @ concat (map (λ(t, ta). map (Pair t) tao) ttas)))"
   (is "thread_start_actions_ok (llist_of (?obs_prefix @ ?E'))")
proof(rule thread_start_actions_okI)
  let ?E = "llist_of (?obs_prefix @ ?E')"
  fix a
  assume a: "a  actions ?E"
    and new: "¬ is_new_action (action_obs ?E a)"
  show "i  a. action_obs ?E i = InitialThreadAction  action_tid ?E i = action_tid ?E a"
  proof(cases "action_tid ?E a = start_tid")
    case True thus ?thesis
      by(auto simp add: lift_start_obs_def action_tid_def action_obs_def)
  next
    case False
    let ?a = "a - length ?obs_prefix"

    from False have a_len: "a  length ?obs_prefix"
      by(rule contrapos_np)(auto simp add: lift_start_obs_def action_tid_def lnth_LCons nth_append split: nat.split)
    hence [simp]: "action_tid ?E a = action_tid (llist_of ?E') ?a" "action_obs ?E a = action_obs (llist_of ?E') ?a"
      by(simp_all add: action_tid_def nth_append action_obs_def)

    from False have not_running: "x ln. thr ?start_state (action_tid (llist_of ?E') ?a)  ((Running, x), ln)"
      by(auto simp add: start_state_def split_beta init_fin_lift_state_def split: if_split_asm)
    
    from a a_len have "?a < length ?E'" by(simp add: actions_def)
    from nth_concat_conv[OF this]
    obtain m n where E'_a: "?E' ! ?a = (λ(t, ta). (t, tao ! n)) (ttas ! m)"
      and n: "n < length snd (ttas ! m)o"
      and m: "m < length ttas"
      and a_conv: "?a = (i<m. length (map (λ(t, ta). map (Pair t) tao) ttas ! i)) + n"
      by(clarsimp simp add: split_def)

    from Red obtain s'' s''' where Red1: "mthr.if.RedT ?start_state (take m ttas) s''"
      and red: "mthr.if.redT s'' (ttas ! m) s'''"
      and Red2: "mthr.if.RedT s''' (drop (Suc m) ttas) s'"
      unfolding mthr.if.RedT_def
      by(subst (asm) (4) id_take_nth_drop[OF m])(blast elim: rtrancl3p_appendE rtrancl3p_converseE)

    from E'_a m n have [simp]: "action_tid (llist_of ?E') ?a = fst (ttas ! m)"
      by(simp add: action_tid_def split_def)
    
    from red obtain status x ln where tst: "thr s'' (fst (ttas ! m)) = ((status, x), ln)" by cases auto
    show ?thesis
    proof(cases "status = PreStart  status = Finished")
      case True
      from Red1 have "Status_no_wait_locks (thr s'')"
        unfolding mthr.if.RedT_def
        by(rule mthr.init_fin_Trsys_preserve_Status_no_wait_locks[OF Status_no_wait_locks_start_state])
      with True tst have "ln = no_wait_locks"
        by(auto dest: Status_no_wait_locks_PreStartD Status_no_wait_locks_FinishedD)
      with red tst True have "snd (ttas ! m)o = [InitialThreadAction]" by(cases) auto
      hence "action_obs ?E a = InitialThreadAction" using a_conv n a_len E'_a
        by(simp add: action_obs_def nth_append split_beta)
      thus ?thesis by(auto)
    next
      case False
      hence "status = Running" by(cases status) auto
      with tst mthr.init_fin_Trsys_Running_InitialThreadAction[OF Red1[unfolded mthr.if.RedT_def] not_running]
      have "(fst (ttas ! m), InitialThreadAction)  set (take m ttas)"
        using E'_a by(auto simp add: action_tid_def split_beta)
      then obtain i where i: "i < m" 
        and nth_i: "ttas ! i = (fst (ttas ! m), InitialThreadAction)"
        unfolding in_set_conv_nth by auto

      let ?i' = "length (concat (map (λ(t, ta). map (Pair t) tao) (take i ttas)))"
      let ?i = "length ?obs_prefix + ?i'"

      from i m nth_i
      have "?i' < length (concat (map (λ(t, ta). map (Pair t) tao) (take m ttas)))"
        apply(simp add: length_concat o_def split_beta)
        apply(subst (6) id_take_nth_drop[where i=i])
        apply(simp_all add: take_map[symmetric] min_def)
        done
      also from m have "  ?a" unfolding a_conv
        by(simp add: length_concat sum_list_sum_nth min_def split_def atLeast0LessThan)
      finally have "?i < a" using a_len by simp
      moreover
      from i m nth_i have "?i' < length ?E'"
        apply(simp add: length_concat o_def split_def)
        apply(subst (7) id_take_nth_drop[where i=i])
        apply(simp_all add: take_map[symmetric])
        done
      from nth_i i E'_a a_conv m
      have "lnth ?E ?i = (fst (ttas ! m), InitialThreadAction)"
        by(simp add: lift_start_obs_def nth_append length_concat o_def split_def)(rule nth_concat_eqI[where k=0 and i=i], simp_all add: take_map o_def split_def)
      ultimately show ?thesis using E'_a
        by(cases "ttas ! m")(auto simp add: action_obs_def action_tid_def nth_append intro!: exI[where x="?i"])
    qed
  qed
qed

(* TODO: use previous lemma for proof *)

lemma thread_start_actions_ok_init_fin:
  assumes E: "E  mthr.if.ℰ (init_fin_lift_state status (start_state f P C M vs))"
  shows "thread_start_actions_ok (lappend (llist_of (lift_start_obs start_tid start_heap_obs)) E)"
  (is "thread_start_actions_ok ?E")
proof(rule thread_start_actions_okI)
  let ?start_heap_obs = "lift_start_obs start_tid start_heap_obs"
  let ?start_state = "init_fin_lift_state status (start_state f P C M vs)"
  fix a
  assume a: "a  actions ?E"
    and a_new: "¬ is_new_action (action_obs ?E a)"
  show "i. i  a  action_obs ?E i = InitialThreadAction  action_tid ?E i = action_tid ?E a"
  proof(cases "action_tid ?E a = start_tid")
    case True thus ?thesis
      by(auto simp add: lift_start_obs_def action_tid_def action_obs_def)
  next
    case False

    let ?a = "a - length ?start_heap_obs"

    from False have "a  length ?start_heap_obs"
      by(rule contrapos_np)(auto simp add: lift_start_obs_def action_tid_def lnth_LCons lnth_lappend1 split: nat.split)
    hence [simp]: "action_tid ?E a = action_tid E ?a" "action_obs ?E a = action_obs E ?a"
      by(simp_all add: action_tid_def lnth_lappend2 action_obs_def)

    from False have not_running: "x ln. thr ?start_state (action_tid E ?a)  ((Running, x), ln)"
      by(auto simp add: start_state_def split_beta init_fin_lift_state_def split: if_split_asm)
    
    from E obtain E' where E': "E = lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E')"
      and τRuns: "mthr.if.mthr.Runs ?start_state E'" by(rule mthr.if.ℰ.cases)
    from a E' a  length ?start_heap_obs
    have enat_a: "enat ?a < llength (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E'))"
      by(cases "llength (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E'))")(auto simp add: actions_def)
    with τRuns obtain m n t ta
    where a_obs: "lnth (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E')) (a - length ?start_heap_obs) = (t, tao ! n)"
      and n: "n < length tao" 
      and m: "enat m < llength E'"
      and a_conv: "?a = (i<m. length snd (lnth E' i)o) + n"
      and E'_m: "lnth E' m = (t, ta)"
      by(rule mthr.if.actions_ℰE_aux)
    from a_obs have [simp]: "action_tid E ?a = t" "action_obs E ?a = tao ! n"
      by(simp_all add: E' action_tid_def action_obs_def)

    let ?E' = "ldropn (Suc m) E'"
    let ?m_E' = "ltake (enat m) E'"
    have E'_unfold: "E' = lappend (ltake (enat m) E') (LCons (lnth E' m) ?E')"
      unfolding ldropn_Suc_conv_ldropn[OF m] by simp
    hence "mthr.if.mthr.Runs ?start_state (lappend ?m_E' (LCons (lnth E' m) ?E'))"
      using τRuns by simp
    then obtain σ' where σ_σ': "mthr.if.mthr.Trsys ?start_state (list_of ?m_E') σ'"
      and τRuns': "mthr.if.mthr.Runs σ' (LCons (lnth E' m) ?E')"
      by(rule mthr.if.mthr.Runs_lappendE) simp
    from τRuns' obtain σ''' where red_a: "mthr.if.redT σ' (t, ta) σ'''"
      and τRuns'': "mthr.if.mthr.Runs σ''' ?E'"
      unfolding E'_m by cases
    from red_a obtain status x ln where tst: "thr σ' t = ((status, x), ln)" by cases auto
    show ?thesis
    proof(cases "status = PreStart  status = Finished")
      case True
      have "Status_no_wait_locks (thr σ')"
        by(rule mthr.init_fin_Trsys_preserve_Status_no_wait_locks[OF _ σ_σ'])(rule Status_no_wait_locks_start_state)
      with True tst have "ln = no_wait_locks"
        by(auto dest: Status_no_wait_locks_PreStartD Status_no_wait_locks_FinishedD)
      with red_a tst True have "tao = [InitialThreadAction]" by(cases) auto
      hence "action_obs E ?a = InitialThreadAction" using a_obs n unfolding E'
        by(simp add: action_obs_def)
      thus ?thesis by(auto)
    next
      case False
      hence "status = Running" by(cases status) auto
      with tst mthr.init_fin_Trsys_Running_InitialThreadAction[OF σ_σ' not_running]
      have "(action_tid E ?a, InitialThreadAction)  set (list_of (ltake (enat m) E'))"
        using a_obs E' by(auto simp add: action_tid_def)
      then obtain i where "i < m" "enat i < llength E'" 
        and nth_i: "lnth E' i = (action_tid E ?a, InitialThreadAction)"
        unfolding in_set_conv_nth 
        by(cases "llength E'")(auto simp add: length_list_of_conv_the_enat lnth_ltake)

      let ?i' = "i<i. length snd (lnth E' i)o"
      let ?i = "length ?start_heap_obs + ?i'"

      from i < m have "(i<m. length snd (lnth E' i)o) = ?i' + (i=i..<m. length snd (lnth E' i)o)"
        unfolding atLeast0LessThan[symmetric] by(subst sum.atLeastLessThan_concat) simp_all
      hence "?i'  ?a" unfolding a_conv by simp
      hence "?i  a" using a  length ?start_heap_obs by arith


      from ?i'  ?a have "enat ?i' < llength E" using enat_a E'
        by(simp add: le_less_trans[where y="enat ?a"])
      from lnth_lconcat_conv[OF this[unfolded E'], folded E']
      obtain k l 
        where nth_i': "lnth E ?i' = lnth (lnth (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E') k) l"
        and l: "l < length snd (lnth E' k)o"
        and k: "enat k < llength E'"
        and i_conv: "enat ?i' = (i<k. llength (lnth (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E') i)) + enat l"
        by(fastforce simp add: split_beta)

      have "(i<k. llength (lnth (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E') i)) =
            (i<k. (enat  (λi. length snd (lnth E' i)o)) i)"
        by(rule sum.cong)(simp_all add: less_trans[where y="enat k"] split_beta k)
      also have " = enat (i<k. length snd (lnth E' i)o)"
        by(rule sum_hom)(simp_all add: zero_enat_def)
      finally have i_conv: "?i' = (i<k. length snd (lnth E' i)o) + l" using i_conv by simp

      have [simp]: "i = k"
      proof(rule ccontr)
        assume "i  k"
        thus False unfolding neq_iff
        proof
          assume "i < k"
          hence "(i<k. length snd (lnth E' i)o) = 
                 (i<i. length snd (lnth E' i)o) + (i=i..<k. length snd (lnth E' i)o)"
            unfolding atLeast0LessThan[symmetric] by(subst sum.atLeastLessThan_concat) simp_all
          with i_conv have "(i=i..<k. length snd (lnth E' i)o) = l" "l = 0" by simp_all
          moreover have "(i=i..<k. length snd (lnth E' i)o)  length snd (lnth E' i)o"
            by(subst sum.atLeast_Suc_lessThan[OF i < k]) simp
          ultimately show False using nth_i by simp
        next
          assume "k < i"
          hence "?i' = (i<k. length snd (lnth E' i)o) + (i=k..<i. length snd (lnth E' i)o)"
            unfolding atLeast0LessThan[symmetric] by(subst sum.atLeastLessThan_concat) simp_all
          with i_conv have "(i=k..<i. length snd (lnth E' i)o) = l" by simp
          moreover have "(i=k..<i. length snd (lnth E' i)o)  length snd (lnth E' k)o"
            by(subst sum.atLeast_Suc_lessThan[OF k < i]) simp
          ultimately show False using l by simp
        qed
      qed
      with l nth_i have [simp]: "l = 0" by simp
      
      hence "lnth E ?i' = (action_tid E ?a, InitialThreadAction)"
        using nth_i nth_i' k by simp
      with ?i  a show ?thesis
        by(auto simp add: action_tid_def action_obs_def lnth_lappend2)
    qed
  qed
qed



end

text ‹In the subsequent locales, convert_RA› refers to @{term "convert_RA"} and is no longer a parameter!›

lemma convert_RA_not_write:
  "ln. ob  set (convert_RA ln)  ¬ is_write_action (NormalAction ob)"
by(auto simp add: convert_RA_def)

lemma ta_seq_consist_convert_RA:
  fixes ln shows
  "ta_seq_consist P vs (llist_of ((map NormalAction  convert_RA) ln))"
proof(rule ta_seq_consist_nthI)
  fix i ad al v
  assume "enat i < llength (llist_of ((map NormalAction  convert_RA) ln :: ('b, 'c) obs_event action list))"
    and "lnth (llist_of ((map NormalAction  convert_RA) ln :: ('b, 'c) obs_event action list)) i = NormalAction (ReadMem ad al v)"
  hence "ReadMem ad al v  set (convert_RA ln :: ('b, 'c) obs_event list)"
    by(auto simp add: in_set_conv_nth)
  hence False by(auto simp add: convert_RA_def)
  thus "b. mrw_values P vs (list_of (ltake (enat i) (llist_of ((map NormalAction  convert_RA) ln)))) (ad, al) = (v, b)" ..
qed

lemma ta_hb_consistent_convert_RA:
  "ln. ta_hb_consistent P E (llist_of (map (Pair t) ((map NormalAction  convert_RA) ln)))"
by(rule ta_hb_consistent_not_ReadI)(auto simp add: convert_RA_def)

locale allocated_multithreaded =
  allocated_heap
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write 
    allocated
    P 
  + 
  mthr: multithreaded final r convert_RA

  for addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool" 
  and allocated :: "'heap  'addr set"
  and final :: "'x  bool"
  and r :: "('addr, 'thread_id, 'x, 'heap, 'addr, ('addr, 'thread_id) obs_event) semantics" ("_  _ -_ _" [50,0,0,50] 80) 
  and P :: "'md prog"
  +
  assumes red_allocated_mono: "t  (x, m) -ta (x', m')  allocated m  allocated m'"
  and red_New_allocatedD:
  " t  (x, m) -ta (x', m'); NewHeapElem ad CTn  set tao 
   ad  allocated m'  ad  allocated m"
  and red_allocated_NewD:
  " t  (x, m) -ta (x', m'); ad  allocated m'; ad  allocated m 
   CTn. NewHeapElem ad CTn  set tao"
  and red_New_same_addr_same:
  " t  (x, m) -ta (x', m'); 
     tao ! i = NewHeapElem a CTn; i < length tao;
     tao ! j = NewHeapElem a CTn'; j < length tao 
   i = j"


sublocale allocated_multithreaded < heap_multithreaded
  addr2thread_id thread_id2addr
  spurious_wakeups
  empty_heap allocate typeof_addr heap_read heap_write
  final r convert_RA P
by(unfold_locales)

context allocated_multithreaded begin

lemma redT_allocated_mono:
  assumes "mthr.redT σ (t, ta) σ'"
  shows "allocated (shr σ)  allocated (shr σ')"
using assms
by cases(auto dest: red_allocated_mono del: subsetI)

lemma RedT_allocated_mono:
  assumes "mthr.RedT σ ttas σ'"
  shows "allocated (shr σ)  allocated (shr σ')"
using assms unfolding mthr.RedT_def
by induct(auto dest!: redT_allocated_mono intro: subset_trans del: subsetI)

lemma init_fin_allocated_mono:
  "t  (x, m) -ta→i (x', m')  allocated m  allocated m'"
by(cases rule: mthr.init_fin.cases)(auto dest: red_allocated_mono)

lemma init_fin_redT_allocated_mono:
  assumes "mthr.if.redT σ (t, ta) σ'"
  shows "allocated (shr σ)  allocated (shr σ')"
using assms
by cases(auto dest: init_fin_allocated_mono del: subsetI)

lemma init_fin_RedT_allocated_mono:
  assumes "mthr.if.RedT σ ttas σ'"
  shows "allocated (shr σ)  allocated (shr σ')"
using assms unfolding mthr.if.RedT_def
by induct(auto dest!: init_fin_redT_allocated_mono intro: subset_trans del: subsetI)

lemma init_fin_red_New_allocatedD:
  assumes "t  (x, m) -ta→i (x', m')" "NormalAction (NewHeapElem ad CTn)  set tao"
  shows "ad  allocated m'  ad  allocated m"
using assms
by cases(auto dest: red_New_allocatedD)

lemma init_fin_red_allocated_NewD:
  assumes "t  (x, m) -ta→i (x', m')" "ad  allocated m'" "ad  allocated m"
  shows "CTn. NormalAction (NewHeapElem ad CTn)  set tao"
using assms
by(cases)(auto dest!: red_allocated_NewD)

lemma init_fin_red_New_same_addr_same:
  assumes "t  (x, m) -ta→i (x', m')"
  and "tao ! i = NormalAction (NewHeapElem a CTn)" "i < length tao"
  and "tao ! j = NormalAction (NewHeapElem a CTn')" "j < length tao"
  shows "i = j"
using assms
by cases(auto dest: red_New_same_addr_same)

lemma init_fin_redT_allocated_NewHeapElemD:
  assumes  "mthr.if.redT s (t, ta) s'"
  and "ad  allocated (shr s')"
  and "ad  allocated (shr s)"
  shows "CTn. NormalAction (NewHeapElem ad CTn)  set tao"
using assms
by(cases)(auto dest: init_fin_red_allocated_NewD)

lemma init_fin_RedT_allocated_NewHeapElemD:
  assumes "mthr.if.RedT s ttas s'"
  and "ad  allocated (shr s')"
  and "ad  allocated (shr s)"
  shows "t ta CTn. (t, ta)  set ttas  NormalAction (NewHeapElem ad CTn)  set tao"
using assms
proof(induct rule: mthr.if.RedT_induct')
  case refl thus ?case by simp
next
  case (step ttas s' t ta s'') thus ?case
    by(cases "ad  allocated (shr s')")(fastforce simp del: split_paired_Ex dest: init_fin_redT_allocated_NewHeapElemD)+
qed

lemma ℰ_new_actions_for_unique:
  assumes E: "E  ℰ_start f P C M vs status"
  and a: "a  new_actions_for P E adal"
  and a': "a'  new_actions_for P E adal"
  shows "a = a'"
using a a'
proof(induct a a' rule: wlog_linorder_le)
  case symmetry thus ?case by simp
next
  case (le a a')
  note a = a  new_actions_for P E adal
    and a' = a'  new_actions_for P E adal
    and a_a' = a  a'
  obtain ad al where adal: "adal = (ad, al)" by(cases adal)
  
  let ?init_obs = "lift_start_obs start_tid start_heap_obs"
  let ?start_state = "init_fin_lift_state status (start_state f P C M vs)"

  have distinct: "distinct (filter (λobs. a CTn. obs = NormalAction (NewHeapElem a CTn)) (map snd ?init_obs))"
    unfolding start_heap_obs_def
    by(fastforce intro: inj_onI intro!: distinct_filter simp add: distinct_map distinct_zipI1 distinct_initialization_list)

  from start_addrs_allocated
  have dom_start_state: "{a. CTn. NormalAction (NewHeapElem a CTn)  snd ` set ?init_obs}  allocated (shr ?start_state)"
    by(fastforce simp add: init_fin_lift_state_conv_simps shr_start_state dest: NewHeapElem_start_heap_obs_start_addrsD subsetD)
  
  show ?case
  proof(cases "a' < length ?init_obs")
    case True
    with a' adal E obtain t_a' CTn_a'
      where CTn_a': "?init_obs ! a' = (t_a', NormalAction (NewHeapElem ad CTn_a'))"
      by(cases "?init_obs ! a'")(fastforce elim!: is_new_action.cases action_loc_aux_cases simp add: action_obs_def lnth_lappend1 new_actions_for_def )+
    from True a_a' have len_a: "a < length ?init_obs" by simp
    with a adal E obtain t_a CTn_a
      where CTn_a: "?init_obs ! a = (t_a, NormalAction (NewHeapElem ad CTn_a))"
      by(cases "?init_obs ! a")(fastforce elim!: is_new_action.cases action_loc_aux_cases simp add: action_obs_def lnth_lappend1 new_actions_for_def )+
    from CTn_a CTn_a' True len_a
    have "NormalAction (NewHeapElem ad CTn_a')  snd ` set ?init_obs"
      and "NormalAction (NewHeapElem ad CTn_a)  snd ` set ?init_obs" unfolding set_conv_nth
      by(fastforce intro: rev_image_eqI)+
    hence [simp]: "CTn_a' = CTn_a" using distinct_start_addrs'
      by(auto simp add: in_set_conv_nth distinct_conv_nth start_heap_obs_def start_addrs_def) blast
    from distinct_filterD[OF distinct, of a' a "NormalAction (NewHeapElem ad CTn_a)"] len_a True CTn_a CTn_a'
    show "a = a'" by simp
  next
    case False
    obtain n where n: "length ?init_obs = n" by blast
    with False have "n  a'" by simp
    
    from E obtain E'' where E: "E = lappend (llist_of ?init_obs) E''"
      and E'': "E''  mthr.if.ℰ ?start_state" by auto
    from E'' obtain E' where E': "E'' = lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E')"
      and τRuns: "mthr.if.mthr.Runs ?start_state E'" by(rule mthr.if.ℰ.cases)
    
    from E E'' a' n n  a' adal have a': "a' - n  new_actions_for P E'' adal"
      by(auto simp add: new_actions_for_def lnth_lappend2 action_obs_def actions_lappend elim: actionsE)
    
    from a' have "a' - n  actions E''" by(auto elim: new_actionsE)
    hence "enat (a' - n) < llength E''" by(rule actionsE)
    with τRuns obtain a'_m a'_n t_a' ta_a'
      where E_a': "lnth E'' (a' - n) = (t_a', ta_a'o ! a'_n)"
      and a'_n: "a'_n < length ta_a'o" and a'_m: "enat a'_m < llength E'"
      and a'_conv: "a' - n = (i<a'_m. length snd (lnth E' i)o) + a'_n"
      and E'_a'_m: "lnth E' a'_m = (t_a', ta_a')"
      unfolding E' by(rule mthr.if.actions_ℰE_aux)
    
    from a' have "is_new_action (action_obs E'' (a' - n))"
      and "(ad, al)  action_loc P E'' (a' - n)"
      unfolding adal by(auto elim: new_actionsE)
    then obtain CTn'
      where "action_obs E'' (a' - n) = NormalAction (NewHeapElem ad CTn')"
      by cases(fastforce)+
    hence New_ta_a': "ta_a'o ! a'_n = NormalAction (NewHeapElem ad CTn')"
      using E_a' a'_n unfolding action_obs_def by simp

    show ?thesis
    proof(cases "a < n")
      case True
      with a adal E n obtain t_a CTn_a where "?init_obs ! a = (t_a, NormalAction (NewHeapElem ad CTn_a))"
        by(cases "?init_obs ! a")(fastforce elim!: is_new_action.cases simp add: action_obs_def lnth_lappend1 new_actions_for_def)+

      with subsetD[OF dom_start_state, of ad] n True
      have a_shr_σ: "ad  allocated (shr ?start_state)"
        by(fastforce simp add: set_conv_nth intro: rev_image_eqI)
      
      have E'_unfold': "E' = lappend (ltake (enat a'_m) E') (LCons (lnth E' a'_m) (ldropn (Suc a'_m) E'))"
        unfolding ldropn_Suc_conv_ldropn[OF a'_m] by simp
      hence "mthr.if.mthr.Runs ?start_state (lappend (ltake (enat a'_m) E') (LCons (lnth E' a'_m) (ldropn (Suc a'_m) E')))"
        using τRuns by simp

      then obtain σ'
        where σ_σ': "mthr.if.mthr.Trsys ?start_state (list_of (ltake (enat a'_m) E')) σ'"
        and τRuns': "mthr.if.mthr.Runs σ' (LCons (lnth E' a'_m) (ldropn (Suc a'_m) E'))"
        by(rule mthr.if.mthr.Runs_lappendE) simp
      from τRuns' obtain σ''
        where red_a': "mthr.if.redT σ' (t_a', ta_a') σ''"
        and τRuns'': "mthr.if.mthr.Runs σ'' (ldropn (Suc a'_m) E')"
        unfolding E'_a'_m by cases
      from New_ta_a' a'_n have "NormalAction (NewHeapElem ad CTn')  set ta_a'o"
        unfolding in_set_conv_nth by blast
      with red_a' obtain x_a' x'_a' m'_a' 
        where red'_a': "mthr.init_fin t_a' (x_a', shr σ') ta_a' (x'_a', m'_a')"
        and σ''': "redT_upd σ' t_a' ta_a' x'_a' m'_a' σ''"
        and ts_t_a': "thr σ' t_a' = (x_a', no_wait_locks)"
        by cases auto
      from red'_a' ‹NormalAction (NewHeapElem ad CTn')  set ta_a'o
      obtain ta'_a' X_a' X'_a'
        where x_a': "x_a' = (Running, X_a')"
        and x'_a': "x'_a' = (Running, X'_a')"
        and ta_a': "ta_a' = convert_TA_initial (convert_obs_initial ta'_a')"
        and red''_a': "t_a'  X_a', shr σ' -ta'_a' X'_a', m'_a'"
        by cases fastforce+
      
      from ta_a' New_ta_a' a'_n have New_ta'_a': "ta'_a'o ! a'_n = NewHeapElem ad CTn'"
        and a'_n': "a'_n < length ta'_a'o" by auto
      hence "NewHeapElem ad CTn'  set ta'_a'o" unfolding in_set_conv_nth by blast
      with red''_a' have allocated_ad': "ad  allocated (shr σ')"
        by(auto dest: red_New_allocatedD)
      
      have "allocated (shr ?start_state)  allocated (shr σ')"
        using σ_σ' unfolding mthr.if.RedT_def[symmetric] by(rule init_fin_RedT_allocated_mono)
      hence False using allocated_ad' a_shr_σ by blast
      thus ?thesis ..
    next
      case False
      hence "n  a" by simp

      from E E'' a n n  a adal have a: "a - n  new_actions_for P E'' adal"
        by(auto simp add: new_actions_for_def lnth_lappend2 action_obs_def actions_lappend elim: actionsE)

      from a have "a - n  actions E''" by(auto elim: new_actionsE)
      hence "enat (a - n) < llength E''" by(rule actionsE)

      with τRuns obtain a_m a_n t_a ta_a 
        where E_a: "lnth E'' (a - n) = (t_a, ta_ao ! a_n)"
        and a_n: "a_n < length ta_ao" and a_m: "enat a_m < llength E'"
        and a_conv: "a - n = (i<a_m. length snd (lnth E' i)o) + a_n"
        and E'_a_m: "lnth E' a_m = (t_a, ta_a)"
        unfolding E' by(rule mthr.if.actions_ℰE_aux)
  
      from a have "is_new_action (action_obs E'' (a - n))" 
        and "(ad, al)  action_loc P E'' (a - n)" 
        unfolding adal by(auto elim: new_actionsE)
      then obtain CTn where "action_obs E'' (a - n) = NormalAction (NewHeapElem ad CTn)"
        by cases(fastforce)+
      hence New_ta_a: " ta_ao ! a_n = NormalAction (NewHeapElem ad CTn)"
        using E_a a_n unfolding action_obs_def by simp
      
      let ?E' = "ldropn (Suc a_m) E'"
  
      have E'_unfold: "E' = lappend (ltake (enat a_m) E') (LCons (lnth E' a_m) ?E')"
        unfolding ldropn_Suc_conv_ldropn[OF a_m] by simp
      hence "mthr.if.mthr.Runs ?start_state (lappend (ltake (enat a_m) E') (LCons (lnth E' a_m) ?E'))"
        using τRuns by simp
      then obtain σ' where σ_σ': "mthr.if.mthr.Trsys ?start_state (list_of (ltake (enat a_m) E')) σ'"
        and τRuns': "mthr.if.mthr.Runs σ' (LCons (lnth E' a_m) ?E')"
        by(rule mthr.if.mthr.Runs_lappendE) simp
      from τRuns' obtain σ''
        where red_a: "mthr.if.redT σ' (t_a, ta_a) σ''"
        and τRuns'': "mthr.if.mthr.Runs σ'' ?E'"
        unfolding E'_a_m by cases
      from New_ta_a a_n have "NormalAction (NewHeapElem ad CTn)  set ta_ao"
        unfolding in_set_conv_nth by blast
      with red_a obtain x_a x'_a m'_a 
        where red'_a: "mthr.init_fin t_a (x_a, shr σ') ta_a (x'_a, m'_a)"
        and σ''': "redT_upd σ' t_a ta_a x'_a m'_a σ''"
        and ts_t_a: "thr σ' t_a = (x_a, no_wait_locks)"
        by cases auto
      from red'_a ‹NormalAction (NewHeapElem ad CTn)  set ta_ao
      obtain ta'_a X_a X'_a
        where x_a: "x_a = (Running, X_a)"
        and x'_a: "x'_a = (Running, X'_a)"
        and ta_a: "ta_a = convert_TA_initial (convert_obs_initial ta'_a)"
        and red''_a: "t_a  (X_a, shr σ') -ta'_a (X'_a, m'_a)"
        by cases fastforce+
      from ta_a New_ta_a a_n have New_ta'_a: "ta'_ao ! a_n = NewHeapElem ad CTn"
        and a_n': "a_n < length ta'_ao" by auto
      hence "NewHeapElem ad CTn  set ta'_ao" unfolding in_set_conv_nth by blast
      with red''_a have allocated_m'_a_ad: "ad  allocated m'_a"
        by(auto dest: red_New_allocatedD)
      
      have "a_m  a'_m"
      proof(rule ccontr)
        assume "¬ ?thesis"
        hence "a'_m < a_m" by simp
        hence "(i<a_m. length snd (lnth E' i)o) = (i<a'_m. length snd (lnth E' i)o) + (i = a'_m..<a_m. length snd (lnth E' i)o)"
          by(simp add: sum_upto_add_nat)
        hence "a' - n < a - n" using a'_m < a_m a'_n E'_a'_m unfolding a_conv a'_conv
          by(subst (asm) sum.atLeast_Suc_lessThan) simp_all
        with a_a' show False by simp
      qed
  
      have a'_less: "a' - n < (a - n) - a_n + length ta_ao"
      proof(rule ccontr)
        assume "¬ ?thesis"
        hence a'_greater: "(a - n) - a_n + length ta_ao  a' - n" by simp
        
        have "a_m < a'_m"
        proof(rule ccontr)
          assume "¬ ?thesis"
          with a_m  a'_m have "a_m = a'_m" by simp
          with a'_greater a_n a'_n E'_a'_m E'_a_m show False
            unfolding a_conv a'_conv by simp
        qed
        hence a'_m_a_m: "enat (a'_m - Suc a_m) < llength ?E'" using a'_m
          by(cases "llength E'") simp_all
        from a_m < a'_m a'_m E'_a'_m
        have E'_a'_m': "lnth ?E' (a'_m - Suc a_m) = (t_a', ta_a')" by simp
    
        have E'_unfold': "?E' = lappend (ltake (enat (a'_m - Suc a_m)) ?E') (LCons (lnth ?E' (a'_m - Suc a_m)) (ldropn (Suc (a'_m - Suc a_m)) ?E'))"
          unfolding ldropn_Suc_conv_ldropn[OF a'_m_a_m] lappend_ltake_enat_ldropn ..
        hence "mthr.if.mthr.Runs σ'' (lappend (ltake (enat (a'_m - Suc a_m)) ?E') (LCons (lnth ?E' (a'_m - Suc a_m)) (ldropn (Suc (a'_m - Suc a_m)) ?E')))"
          using τRuns'' by simp
        then obtain σ'''
          where σ''_σ''': "mthr.if.mthr.Trsys σ'' (list_of (ltake (enat (a'_m - Suc a_m)) ?E')) σ'''"
          and τRuns''': "mthr.if.mthr.Runs σ''' (LCons (lnth ?E' (a'_m - Suc a_m)) (ldropn (Suc (a'_m - Suc a_m)) ?E'))"
          by(rule mthr.if.mthr.Runs_lappendE) simp
        from τRuns''' obtain σ''''
          where red_a': "mthr.if.redT σ''' (t_a', ta_a') σ''''"
          and τRuns'''': "mthr.if.mthr.Runs σ'''' (ldropn (Suc (a'_m - Suc a_m)) ?E')"
          unfolding E'_a'_m' by cases
        from New_ta_a' a'_n have "NormalAction (NewHeapElem ad CTn')  set ta_a'o"
          unfolding in_set_conv_nth by blast
        with red_a' obtain x_a' x'_a' m'_a' 
          where red'_a': "mthr.init_fin t_a' (x_a', shr σ''') ta_a' (x'_a', m'_a')"
          and σ'''''': "redT_upd σ''' t_a' ta_a' x'_a' m'_a' σ''''"
          and ts_t_a': "thr σ''' t_a' = (x_a', no_wait_locks)"
          by cases auto
        from red'_a' ‹NormalAction (NewHeapElem ad CTn')  set ta_a'o
        obtain ta'_a' X_a' X'_a' 
          where x_a': "x_a' = (Running, X_a')"
          and x'_a': "x'_a' = (Running, X'_a')"
          and ta_a': "ta_a' = convert_TA_initial (convert_obs_initial ta'_a')"
          and red''_a': "t_a'  (X_a', shr σ''') -ta'_a' (X'_a', m'_a')"
          by cases fastforce+
        from ta_a' New_ta_a' a'_n have New_ta'_a': "ta'_a'o ! a'_n = NewHeapElem ad CTn'"
          and a'_n': "a'_n < length ta'_a'o" by auto
        hence "NewHeapElem ad CTn'  set ta'_a'o" unfolding in_set_conv_nth by blast
        with red''_a' have allocated_ad': "ad  allocated (shr σ''')"
          by(auto dest: red_New_allocatedD)
    
        have "allocated m'_a = allocated (shr σ'')" using σ''' by auto
        also have "  allocated (shr σ''')"
          using σ''_σ''' unfolding mthr.if.RedT_def[symmetric] by(rule init_fin_RedT_allocated_mono)
        finally have "ad  allocated (shr σ''')" using allocated_m'_a_ad by blast
        with allocated_ad' show False by contradiction
      qed
      
      from a_m  a'_m have [simp]: "a_m = a'_m"
      proof(rule le_antisym)
        show "a'_m  a_m"
        proof(rule ccontr)
          assume "¬ ?thesis"
          hence "a_m < a'_m" by simp
          hence "(i<a'_m. length snd (lnth E' i)o) = (i<a_m. length snd (lnth E' i)o) + (i = a_m..<a'_m. length snd (lnth E' i)o)"
            by(simp add: sum_upto_add_nat)
          with a'_less a_m < a'_m E'_a_m a_n a'_n show False
            unfolding a'_conv a_conv by(subst (asm) sum.atLeast_Suc_lessThan) simp_all
        qed
      qed
      with E'_a_m E'_a'_m have [simp]: "t_a' = t_a" "ta_a' = ta_a" by simp_all
      from New_ta_a' a'_n ta_a have a'_n': "a'_n < length ta'_ao"
        and New_ta'_a': "ta'_ao ! a'_n = NewHeapElem ad CTn'" by auto
      with red''_a New_ta'_a a_n' have "a'_n = a_n"
        by(auto dest: red_New_same_addr_same)
      with a_m = a'_m have "a - n = a' - n" unfolding a_conv a'_conv by simp
      thus ?thesis using n  a n  a' by simp
    qed
  qed
qed

end


text ‹Knowledge of addresses of a multithreaded state›

fun ka_Val :: "'addr val  'addr set"
where
  "ka_Val (Addr a) = {a}"
| "ka_Val _ = {}"

fun new_obs_addr :: "('addr, 'thread_id) obs_event  'addr set"
where
  "new_obs_addr (ReadMem ad al (Addr ad')) = {ad'}"
| "new_obs_addr (NewHeapElem ad hT) = {ad}"
| "new_obs_addr _ = {}"

lemma new_obs_addr_cases[consumes 1, case_names ReadMem NewHeapElem, cases set]:
  assumes "ad  new_obs_addr ob"
  obtains ad' al where "ob = ReadMem ad' al (Addr ad)"
  | CTn where "ob = NewHeapElem ad CTn"
using assms
by(cases ob rule: new_obs_addr.cases) auto

definition new_obs_addrs :: "('addr, 'thread_id) obs_event list  'addr set"
where
  "new_obs_addrs obs = (new_obs_addr ` set obs)"

fun new_obs_addr_if :: "('addr, 'thread_id) obs_event action  'addr set"
where
  "new_obs_addr_if (NormalAction a) = new_obs_addr a"
| "new_obs_addr_if _ = {}"

definition new_obs_addrs_if :: "('addr, 'thread_id) obs_event action list  'addr set"
where 
  "new_obs_addrs_if obs = (new_obs_addr_if ` set obs)"

lemma ka_Val_subset_new_obs_Addr_ReadMem:
  "ka_Val v  new_obs_addr (ReadMem ad al v)"
by(cases v) simp_all

lemma typeof_ka: "typeof v  None  ka_Val v = {}"
by(cases v) simp_all

lemma ka_Val_undefined_value [simp]:
  "ka_Val undefined_value = {}"
apply(cases "undefined_value :: 'a val")
apply(bestsimp simp add: undefined_value_not_Addr dest: subst)+
done

locale known_addrs_base =
  fixes known_addrs :: "'t  'x  'addr set"
begin

definition known_addrs_thr :: "('l, 't, 'x) thread_info  'addr set"
where "known_addrs_thr ts = (t  dom ts. known_addrs t (fst (the (ts t))))"

definition known_addrs_state :: "('l,'t,'x,'m,'w) state  'addr set"
where "known_addrs_state s = known_addrs_thr (thr s)"

lemma known_addrs_state_simps [simp]:
  "known_addrs_state (ls, (ts, m), ws) = known_addrs_thr ts"
by(simp add: known_addrs_state_def)

lemma known_addrs_thr_cases[consumes 1, case_names known_addrs, cases set: known_addrs_thr]:
  assumes "ad  known_addrs_thr ts"
  and "t x ln.  ts t = (x, ln); ad  known_addrs t x   thesis"
  shows thesis
using assms
by(auto simp add: known_addrs_thr_def ran_def)

lemma known_addrs_stateI:
  "ln.  ad  known_addrs t x; thr s t = (x, ln)   ad  known_addrs_state s"
by(fastforce simp add: known_addrs_state_def known_addrs_thr_def intro: rev_bexI)

fun known_addrs_if :: "'t  status × 'x  'addr set"
where "known_addrs_if t (s, x) = known_addrs t x"

end

locale if_known_addrs_base = 
  known_addrs_base known_addrs 
  +
  multithreaded_base final r convert_RA
  for known_addrs :: "'t  'x  'addr set"
  and final :: "'x  bool"
  and r :: "('addr, 't, 'x, 'heap, 'addr, 'obs) semantics" ("_  _ -_ _" [50,0,0,50] 80)
  and convert_RA :: "'addr released_locks  'obs list"

sublocale if_known_addrs_base < "if": known_addrs_base known_addrs_if .

locale known_addrs =
  allocated_multithreaded (* Check why all the heap operations are necessary in this locale! *)
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write
    allocated
    final r
    P 
  +
  if_known_addrs_base known_addrs final r convert_RA

  for addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool" 
  and allocated :: "'heap  'addr set"
  and known_addrs :: "'thread_id  'x  'addr set"
  and final :: "'x  bool"
  and r :: "('addr, 'thread_id, 'x, 'heap, 'addr, ('addr, 'thread_id) obs_event) semantics" ("_  _ -_ _" [50,0,0,50] 80) 
  and P :: "'md prog"
  +
  assumes red_known_addrs_new:
  "t  x, m -ta x', m'
   known_addrs t x'  known_addrs t x  new_obs_addrs tao"
  and red_known_addrs_new_thread:
  " t  x, m -ta x', m'; NewThread t' x'' m''  set tat 
   known_addrs t' x''  known_addrs t x"
  and red_read_knows_addr:
  " t  x, m -ta x', m'; ReadMem ad al v  set tao 
   ad  known_addrs t x"
  and red_write_knows_addr:
  " t  x, m -ta x', m'; tao ! n = WriteMem ad al (Addr ad'); n < length tao 
   ad'  known_addrs t x  ad'  new_obs_addrs (take n tao)"
  ― ‹second possibility necessary for @{term heap_clone}
begin

notation mthr.redT_syntax1 ("_ -__ _" [50,0,0,50] 80)

lemma if_red_known_addrs_new: 
  assumes "t  (x, m) -ta→i (x', m')"
  shows "known_addrs_if t x'  known_addrs_if t x  new_obs_addrs_if tao"
using assms
by cases(auto dest!: red_known_addrs_new simp add: new_obs_addrs_if_def new_obs_addrs_def)

lemma if_red_known_addrs_new_thread:
  assumes "t  (x, m) -ta→i (x', m')" "NewThread t' x'' m''  set tat"
  shows "known_addrs_if t' x''  known_addrs_if t x"
using assms
by cases(fastforce dest: red_known_addrs_new_thread)+

lemma if_red_read_knows_addr:
  assumes "t  (x, m) -ta→i (x', m')" "NormalAction (ReadMem ad al v)  set tao"
  shows "ad  known_addrs_if t x"
using assms
by cases(fastforce dest: red_read_knows_addr)+

lemma if_red_write_knows_addr:
  assumes "t  (x, m) -ta→i (x', m')"
  and "tao ! n = NormalAction (WriteMem ad al (Addr ad'))" "n < length tao"
  shows "ad'  known_addrs_if t x  ad'  new_obs_addrs_if (take n tao)"
using assms
by cases(auto dest: red_write_knows_addr simp add: new_obs_addrs_if_def new_obs_addrs_def take_map)

lemma if_redT_known_addrs_new:
  assumes redT: "mthr.if.redT s (t, ta) s'"
  shows "if.known_addrs_state s'  if.known_addrs_state s  new_obs_addrs_if tao"
using redT
proof(cases)
  case redT_acquire thus ?thesis
    by(cases s)(fastforce simp add: if.known_addrs_thr_def split: if_split_asm intro: rev_bexI)
next
  case (redT_normal x x' m)
  note red = t  (x, shr s) -ta→i (x', m)
  show ?thesis
  proof
    fix ad
    assume "ad  if.known_addrs_state s'"
    hence "ad  if.known_addrs_thr (thr s')" by(simp add: if.known_addrs_state_def)
    then obtain t' x'' ln'' where ts't': "thr s' t' = (x'', ln'')" 
      and ad: "ad  known_addrs_if t' x''"
      by(rule if.known_addrs_thr_cases)
    show "ad  if.known_addrs_state s  new_obs_addrs_if tao"
    proof(cases "thr s t'")
      case None
      with redT_normal ‹thr s' t' = (x'', ln'')
      obtain m'' where "NewThread t' x'' m''  set tat"
        by(fastforce dest: redT_updTs_new_thread split: if_split_asm)
      with red have "known_addrs_if t' x''  known_addrs_if t x" by(rule if_red_known_addrs_new_thread)
      also have "  known_addrs_if t x  new_obs_addrs_if tao" by simp
      finally have "ad  known_addrs_if t x  new_obs_addrs_if tao" using ad by blast
      thus ?thesis using ‹thr s t = (x, no_wait_locks) by(blast intro: if.known_addrs_stateI)
    next
      case (Some xln)
      show ?thesis
      proof(cases "t = t'")
        case True
        with redT_normal ts't' if_red_known_addrs_new[OF red] ad
        have "ad  known_addrs_if t x  new_obs_addrs_if tao" by auto
        thus ?thesis using ‹thr s t = (x, no_wait_locks) by(blast intro: if.known_addrs_stateI)
      next
        case False
        with ts't' redT_normal ad Some show ?thesis
          by(fastforce dest: redT_updTs_Some[where ts="thr s" and t=t'] intro: if.known_addrs_stateI)
      qed
    qed
  qed
qed

lemma if_redT_read_knows_addr:
  assumes redT: "mthr.if.redT s (t, ta) s'"
  and read: "NormalAction (ReadMem ad al v)  set tao"
  shows "ad  if.known_addrs_state s"
using redT
proof(cases)
  case redT_acquire thus ?thesis using read by auto
next
  case (redT_normal x x' m')
  with if_red_read_knows_addr[OF t  (x, shr s) -ta→i (x', m') read]
  show ?thesis
    by(auto simp add: if.known_addrs_state_def if.known_addrs_thr_def intro: bexI[where x=t])
qed

lemma init_fin_redT_known_addrs_subset:
  assumes "mthr.if.redT s (t, ta) s'"
  shows "if.known_addrs_state s'  if.known_addrs_state s  known_addrs_if t (fst (the (thr s' t)))"
using assms
apply(cases)
 apply(rule subsetI)
 apply(clarsimp simp add: if.known_addrs_thr_def split: if_split_asm)
 apply(rename_tac status x status' x' m' a ws' t'' status'' x'' ln'')
 apply(case_tac "thr s t''")
  apply(drule (2) redT_updTs_new_thread)
  apply clarsimp
  apply(drule (1) if_red_known_addrs_new_thread)
  apply simp
  apply(drule (1) subsetD)
  apply(rule_tac x="(status, x)" in if.known_addrs_stateI)
   apply(simp)
  apply simp
 apply(frule_tac t="t''" in redT_updTs_Some, assumption)
 apply clarsimp
 apply(rule_tac x="(status'', x'')" in if.known_addrs_stateI)
  apply simp
 apply simp
apply(auto simp add: if.known_addrs_state_def if.known_addrs_thr_def split: if_split_asm)
done

lemma w_values_no_write_unchanged:
  assumes no_write: "w.  w  set obs; is_write_action w; adal  action_loc_aux P w   False"
  shows "w_values P vs obs adal = vs adal"
using assms
proof(induct obs arbitrary: vs)
  case Nil show ?case by simp
next
  case (Cons ob obs)
  from Cons.prems[of ob]
  have "w_value P vs ob adal = vs adal"
    by(cases adal)(cases ob rule: w_value_cases, auto simp add: addr_locs_def split: htype.split_asm, blast+)
  moreover
  have "w_values P (w_value P vs ob) obs adal = w_value P vs ob adal"
  proof(rule Cons.hyps)
    fix w
    assume "w  set obs" "is_write_action w" "adal  action_loc_aux P w"
    with Cons.prems[of w] ‹w_value P vs ob adal = vs adal
    show "False" by simp
  qed
  ultimately show ?case by simp
qed

lemma redT_non_speculative_known_addrs_allocated:
  assumes red: "mthr.if.redT s (t, ta) s'"
  and tasc: "non_speculative P vs (llist_of tao)"
  and ka: "if.known_addrs_state s  allocated (shr s)"
  and vs: "w_addrs vs  allocated (shr s)"
  shows "if.known_addrs_state s'  allocated (shr s')" (is "?thesis1")
  and "w_addrs (w_values P vs tao)  allocated (shr s')" (is "?thesis2")
proof -
  have "?thesis1  ?thesis2" using red
  proof(cases)
    case (redT_acquire x ln n)
    hence "if.known_addrs_state s' = if.known_addrs_state s"
      by(auto 4 4 simp add: if.known_addrs_state_def if.known_addrs_thr_def split: if_split_asm dest: bspec)
    also note ka 
    also from redT_acquire have "shr s = shr s'" by simp
    finally have "if.known_addrs_state s'  allocated (shr s')" .
    moreover have "w_values P vs tao = vs" using redT_acquire
      by(fastforce intro!: w_values_no_write_unchanged del: equalityI dest: convert_RA_not_write)
    ultimately show ?thesis using vs by(simp add: ‹shr s = shr s')
  next
    case (redT_normal x x' m')
    note red = t  (x, shr s) -ta→i (x', m')
      and tst = ‹thr s t = (x, no_wait_locks)
    have allocated_subset: "allocated (shr s)  allocated (shr s')"
      using ‹mthr.if.redT s (t, ta) s' by(rule init_fin_redT_allocated_mono)
    with vs have vs': "w_addrs vs  allocated (shr s')" by blast
    { fix obs obs'
      assume "tao = obs @ obs'"
      moreover with tasc have "non_speculative P vs (llist_of obs)"
        by(simp add: lappend_llist_of_llist_of[symmetric] non_speculative_lappend del: lappend_llist_of_llist_of)
      ultimately have "w_addrs (w_values P vs obs)  new_obs_addrs_if obs  allocated (shr s')" 
        (is "?concl obs")
      proof(induct obs arbitrary: obs' rule: rev_induct)
        case Nil thus ?case using vs' by(simp add: new_obs_addrs_if_def)
      next
        case (snoc ob obs)
        note ta = tao = (obs @ [ob]) @ obs'
        note tasc = ‹non_speculative P vs (llist_of (obs @ [ob]))
        from snoc have IH: "?concl obs"
          by(simp add: lappend_llist_of_llist_of[symmetric] non_speculative_lappend del: lappend_llist_of_llist_of)
        hence "?concl (obs @ [ob])"
        proof(cases "ob" rule: mrw_value_cases)
          case (1 ad' al v)
          note ob = ob = NormalAction (WriteMem ad' al v)
          with ta have Write: "tao ! length obs = NormalAction (WriteMem ad' al v)" by simp
          show ?thesis
          proof
            fix ad''
            assume "ad''  w_addrs (w_values P vs (obs @ [ob]))  new_obs_addrs_if (obs @ [ob])"
            hence "ad''  w_addrs (w_values P vs obs)  new_obs_addrs_if obs  v = Addr ad''"
              by(auto simp add: ob w_addrs_def ran_def new_obs_addrs_if_def split: if_split_asm)
            thus "ad''  allocated (shr s')"
            proof
              assume "ad''  w_addrs (w_values P vs obs)  new_obs_addrs_if obs"
              also note IH finally show ?thesis .
            next
              assume v: "v = Addr ad''"
              with Write have "tao ! length obs = NormalAction (WriteMem ad' al (Addr ad''))" by simp
              with red have "ad''  known_addrs_if t x  ad''  new_obs_addrs_if (take (length obs) tao)"
                by(rule if_red_write_knows_addr)(simp add: ta)
              thus ?thesis
              proof
                assume "ad''  known_addrs_if t x"
                hence "ad''  if.known_addrs_state s" using tst by(rule if.known_addrs_stateI)
                with ka allocated_subset show ?thesis by blast
              next
                assume "ad''  new_obs_addrs_if (take (length obs) tao)"
                with ta have "ad''  new_obs_addrs_if obs" by simp
                with IH show ?thesis by blast
              qed
            qed
          qed
        next
          case (2 ad hT)

          hence ob: "ob = NormalAction (NewHeapElem ad hT)" by simp
          hence "w_addrs (w_values P vs (obs @ [ob]))  w_addrs (w_values P vs obs)"
            by(cases hT)(auto simp add: w_addrs_def default_val_not_Addr Addr_not_default_val)
          moreover from ob ta have "NormalAction (NewHeapElem ad hT)  set tao" by simp
          from init_fin_red_New_allocatedD[OF red this] have "ad  allocated m'" ..
          with redT_normal have "ad  allocated (shr s')" by auto
          ultimately show ?thesis using IH ob by(auto simp add: new_obs_addrs_if_def)
        next
          case (4 ad al v)
          note ob = ob = NormalAction (ReadMem ad al v)
          { fix ad'
            assume v: "v = Addr ad'"
            with tasc ob have mrw: "Addr ad'  w_values P vs obs (ad, al)"
              by(auto simp add: lappend_llist_of_llist_of[symmetric] non_speculative_lappend simp del: lappend_llist_of_llist_of)
            hence "ad'  w_addrs (w_values P vs obs)"
              by(auto simp add: w_addrs_def)
            with IH have "ad'  allocated (shr s')" by blast }
          with ob IH show ?thesis by(cases v)(simp_all add: new_obs_addrs_if_def)
        qed(simp_all add: new_obs_addrs_if_def)
        thus ?case by simp
      qed }
    note this[of "tao" "[]"]
    moreover have "if.known_addrs_state s'  if.known_addrs_state s  new_obs_addrs_if tao"
      using ‹mthr.if.redT s (t, ta) s' by(rule if_redT_known_addrs_new)
    ultimately show ?thesis using ka allocated_subset by blast
  qed
  thus ?thesis1 ?thesis2 by simp_all
qed


lemma RedT_non_speculative_known_addrs_allocated:
  assumes red: "mthr.if.RedT s ttas s'"
  and tasc: "non_speculative P vs (llist_of (concat (map (λ(t, ta). tao) ttas)))"
  and ka: "if.known_addrs_state s  allocated (shr s)"
  and vs: "w_addrs vs  allocated (shr s)"
  shows "if.known_addrs_state s'  allocated (shr s')" (is "?thesis1 s'")
  and "w_addrs (w_values P vs (concat (map (λ(t, ta). tao) ttas)))  allocated (shr s')" (is "?thesis2 s' ttas")
proof -
  from red tasc have "?thesis1 s'  ?thesis2 s' ttas"
  proof(induct rule: mthr.if.RedT_induct')
    case refl thus ?case using ka vs by simp
  next
    case (step ttas s' t ta s'')
    hence "non_speculative P (w_values P vs (concat (map (λ(t, ta). tao) ttas))) (llist_of tao)"
      and "?thesis1 s'" "?thesis2 s' ttas"
      by(simp_all add: lappend_llist_of_llist_of[symmetric] non_speculative_lappend del: lappend_llist_of_llist_of)
    from redT_non_speculative_known_addrs_allocated[OF ‹mthr.if.redT s' (t, ta) s'' this]
    show ?case by simp
  qed
  thus "?thesis1 s'" "?thesis2 s' ttas" by simp_all
qed

lemma read_ex_NewHeapElem [consumes 5, case_names start Red]:
  assumes RedT: "mthr.if.RedT (init_fin_lift_state status (start_state f P C M vs)) ttas s"
  and red: "mthr.if.redT s (t, ta) s'"
  and read: "NormalAction (ReadMem ad al v)  set tao"
  and sc: "non_speculative P (λ_. {}) (llist_of (map snd (lift_start_obs start_tid start_heap_obs) @ concat (map (λ(t, ta). tao) ttas)))"
  and known: "known_addrs start_tid (f (fst (method P C M)) M (fst (snd (method P C M))) (fst (snd (snd (method P C M)))) (the (snd (snd (snd (method P C M))))) vs)  allocated start_heap"
  obtains (start) CTn where "NewHeapElem ad CTn  set start_heap_obs"
  | (Red) ttas' s'' t' ta' s''' ttas'' CTn
  where "mthr.if.RedT (init_fin_lift_state status (start_state f P C M vs)) ttas' s''"
  and "mthr.if.redT s'' (t', ta') s'''"
  and "mthr.if.RedT s''' ttas'' s"
  and "ttas = ttas' @ (t', ta') # ttas''"
  and "NormalAction (NewHeapElem ad CTn)  set ta'o"
proof -
  let ?start_state = "init_fin_lift_state status (start_state f P C M vs)"
  let ?obs_prefix = "lift_start_obs start_tid start_heap_obs"
  let ?vs_start = "w_values P (λ_. {}) (map snd ?obs_prefix)"

  from sc have "non_speculative P (w_values P (λ_. {}) (map snd (lift_start_obs start_tid start_heap_obs))) (llist_of (concat (map (λ(t, ta). tao) ttas)))"
    by(simp add: non_speculative_lappend lappend_llist_of_llist_of[symmetric] del: lappend_llist_of_llist_of)
  with RedT have "if.known_addrs_state s  allocated (shr s)"
  proof(rule RedT_non_speculative_known_addrs_allocated)
    show "if.known_addrs_state ?start_state  allocated (shr ?start_state)"
      using known
      by(auto simp add: if.known_addrs_state_def if.known_addrs_thr_def start_state_def init_fin_lift_state_def split_beta split: if_split_asm)
    
    have "w_addrs ?vs_start  w_addrs (λ_. {})" by(rule w_addrs_lift_start_heap_obs)
    thus "w_addrs ?vs_start  allocated (shr ?start_state)" by simp
  qed
  also from red read obtain x_ra x'_ra m'_ra 
    where red'_ra: "t  (x_ra, shr s) -ta→i (x'_ra, m'_ra)"
    and s': "redT_upd s t ta x'_ra m'_ra s'"
    and ts_t: "thr s t = (x_ra, no_wait_locks)"
    by cases auto
  from red'_ra read
  have "ad  known_addrs_if t x_ra" by(rule if_red_read_knows_addr)
  hence "ad  if.known_addrs_state s" using ts_t by(rule if.known_addrs_stateI)
  finally have "ad  allocated (shr s)" .

  show ?thesis
  proof(cases "ad  allocated start_heap")
    case True
    then obtain CTn where "NewHeapElem ad CTn  set start_heap_obs"
      unfolding start_addrs_allocated by(blast dest: start_addrs_NewHeapElem_start_heap_obsD)
    thus ?thesis by(rule start)
  next
    case False
    hence "ad  allocated (shr ?start_state)" by(simp add: start_state_def split_beta shr_init_fin_lift_state)
    with RedT ad  allocated (shr s) obtain t' ta' CTn
      where tta: "(t', ta')  set ttas"
      and new: "NormalAction (NewHeapElem ad CTn)  set ta'o"
      by(blast dest: init_fin_RedT_allocated_NewHeapElemD)
    from tta obtain ttas' ttas'' where ttas: "ttas = ttas' @ (t', ta') # ttas''" by(auto dest: split_list)
    with RedT obtain s'' s''' 
      where "mthr.if.RedT ?start_state ttas' s''"
      and "mthr.if.redT s'' (t', ta') s'''"
      and "mthr.if.RedT s''' ttas'' s"
      unfolding mthr.if.RedT_def by(auto elim!: rtrancl3p_appendE dest!: converse_rtrancl3p_step)
    thus thesis using ttas new by(rule Red)
  qed
qed

end

locale known_addrs_typing =
  known_addrs
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write
    allocated known_addrs
    final r P
  for addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool" 
  and allocated :: "'heap  'addr set"
  and known_addrs :: "'thread_id  'x  'addr set"
  and final :: "'x  bool"
  and r :: "('addr, 'thread_id, 'x, 'heap, 'addr, ('addr, 'thread_id) obs_event) semantics" ("_  _ -_ _" [50,0,0,50] 80) 
  and wfx :: "'thread_id  'x  'heap  bool"
  and P :: "'md prog"
  +
  assumes wfs_non_speculative_invar:
  " t  (x, m) -ta (x', m'); wfx t x m;
     vs_conf P m vs; non_speculative P vs (llist_of (map NormalAction tao)) 
   wfx t x' m'"
  and wfs_non_speculative_spawn:
  " t  (x, m) -ta (x', m'); wfx t x m;
     vs_conf P m vs; non_speculative P vs (llist_of (map NormalAction tao));
     NewThread t'' x'' m''  set tat 
   wfx t'' x'' m''"
  and wfs_non_speculative_other:
  " t  (x, m) -ta (x', m'); wfx t x m;
     vs_conf P m vs; non_speculative P vs (llist_of (map NormalAction tao));
     wfx t'' x'' m 
   wfx t'' x'' m'"
  and wfs_non_speculative_vs_conf:
  " t  (x, m) -ta (x', m'); wfx t x m;
     vs_conf P m vs; non_speculative P vs (llist_of (take n (map NormalAction tao))) 
   vs_conf P m' (w_values P vs (take n (map NormalAction tao)))"
  and red_read_typeable:
  " t  (x, m) -ta (x', m'); wfx t x m; ReadMem ad al v  set tao  
   T. P,m  ad@al : T"
  and red_NewHeapElemD:
  " t  (x, m) -ta (x', m'); wfx t x m; NewHeapElem ad hT  set tao 
   typeof_addr m' ad = hT"
  and red_hext_incr: 
  " t  (x, m) -ta (x', m'); wfx t x m; 
     vs_conf P m vs; non_speculative P vs (llist_of (map NormalAction tao)) 
   m  m'"
begin

lemma redT_wfs_non_speculative_invar:
  assumes redT: "mthr.redT s (t, ta) s'"
  and wfx: "ts_ok wfx (thr s) (shr s)"
  and vs: "vs_conf P (shr s) vs"
  and ns: "non_speculative P vs (llist_of (map NormalAction tao))"
  shows "ts_ok wfx (thr s') (shr s')"
using redT
proof(cases)
  case (redT_normal x x' m')
  with vs wfx ns show ?thesis
    apply(clarsimp intro!: ts_okI split: if_split_asm)
     apply(erule wfs_non_speculative_invar, auto dest: ts_okD)
    apply(rename_tac t' x' ln ws')
    apply(case_tac "thr s t'")
    apply(frule (2) redT_updTs_new_thread, clarify)
    apply(frule (1) mthr.new_thread_memory)
    apply(auto intro: wfs_non_speculative_other wfs_non_speculative_spawn dest: ts_okD simp add: redT_updTs_Some)
    done
next
  case (redT_acquire x ln n)
  thus ?thesis using wfx by(auto intro!: ts_okI dest: ts_okD split: if_split_asm)
qed

lemma redT_wfs_non_speculative_vs_conf:
  assumes redT: "mthr.redT s (t, ta) s'"
  and wfx: "ts_ok wfx (thr s) (shr s)"
  and conf: "vs_conf P (shr s) vs"
  and ns: "non_speculative P vs (llist_of (take n (map NormalAction tao)))"
  shows "vs_conf P (shr s') (w_values P vs (take n (map NormalAction tao)))"
using redT
proof(cases)
  case (redT_normal x x' m')
  thus ?thesis using ns conf wfx by(auto dest: wfs_non_speculative_vs_conf ts_okD)
next
  case (redT_acquire x l ln)
  have "w_values P vs (take n (map NormalAction (convert_RA ln :: ('addr, 'thread_id) obs_event list))) = vs"
    by(fastforce dest: in_set_takeD simp add: convert_RA_not_write intro!: w_values_no_write_unchanged del: equalityI)
  thus ?thesis using conf redT_acquire by(auto)
qed

lemma if_redT_non_speculative_invar:
  assumes red: "mthr.if.redT s (t, ta) s'"
  and ts_ok: "ts_ok (init_fin_lift wfx) (thr s) (shr s)"
  and sc: "non_speculative P vs (llist_of tao)" 
  and vs: "vs_conf P (shr s) vs"
  shows "ts_ok (init_fin_lift wfx) (thr s') (shr s')"
proof -
  let ?s = "λs. (locks s, (λt. map_option (λ((status, x), ln). (x, ln)) (thr s t), shr s), wset s, interrupts s)"
  
  from ts_ok have ts_ok': "ts_ok wfx (thr (?s s)) (shr (?s s))" by(auto intro!: ts_okI dest: ts_okD)
  from vs have vs': "vs_conf P (shr (?s s)) vs" by simp

  from red show ?thesis
  proof(cases)
    case (redT_normal x x' m)
    note tst = ‹thr s t = (x, no_wait_locks)
    from t  (x, shr s) -ta→i (x', m)
    show ?thesis 
    proof(cases)
      case (NormalAction X TA X')
      from ta = convert_TA_initial (convert_obs_initial TA) ‹mthr.if.actions_ok s t ta
      have "mthr.actions_ok (?s s) t TA"
        by(auto elim: rev_iffD1[OF _ thread_oks_ts_change] cond_action_oks_final_change)

      with tst NormalAction ‹redT_upd s t ta x' m s' have "mthr.redT (?s s) (t, TA) (?s s')"
        using map_redT_updTs[of snd "thr s" "tat"]
        by(auto intro!: mthr.redT.intros simp add: split_def map_prod_def o_def fun_eq_iff)
      moreover note ts_ok' vs'
      moreover from ta = convert_TA_initial (convert_obs_initial TA) have "tao = map NormalAction TAo" by(auto)
      with sc have "non_speculative P vs (llist_of (map NormalAction TAo))" by simp
      ultimately have "ts_ok wfx (thr (?s s')) (shr (?s s'))"
        by(auto dest: redT_wfs_non_speculative_invar)
      thus ?thesis using tao = map NormalAction TAo by(auto intro!: ts_okI dest: ts_okD)
    next
      case InitialThreadAction
      with redT_normal ts_ok' vs show ?thesis
        by(auto 4 3 intro!: ts_okI dest: ts_okD split: if_split_asm)
    next
      case ThreadFinishAction
      with redT_normal ts_ok' vs show ?thesis
        by(auto 4 3 intro!: ts_okI dest: ts_okD split: if_split_asm)
    qed
  next
    case (redT_acquire x ln l)
    thus ?thesis using vs ts_ok by(auto 4 3 intro!: ts_okI dest: ts_okD split: if_split_asm)
  qed
qed

lemma if_redT_non_speculative_vs_conf:
  assumes red: "mthr.if.redT s (t, ta) s'"
  and ts_ok: "ts_ok (init_fin_lift wfx) (thr s) (shr s)"
  and sc: "non_speculative P vs (llist_of (take n tao))"
  and vs: "vs_conf P (shr s) vs"
  shows "vs_conf P (shr s') (w_values P vs (take n tao))"
proof -
  let ?s = "λs. (locks s, (λt. map_option (λ((status, x), ln). (x, ln)) (thr s t), shr s), wset s, interrupts s)"
  
  from ts_ok have ts_ok': "ts_ok wfx (thr (?s s)) (shr (?s s))" by(auto intro!: ts_okI dest: ts_okD)
  from vs have vs': "vs_conf P (shr (?s s)) vs" by simp

  from red show ?thesis
  proof(cases)
    case (redT_normal x x' m)
    note tst = ‹thr s t = (x, no_wait_locks)
    from t  (x, shr s) -ta→i (x', m)
    show ?thesis 
    proof(cases)
      case (NormalAction X TA X')
      from ta = convert_TA_initial (convert_obs_initial TA) ‹mthr.if.actions_ok s t ta
      have "mthr.actions_ok (?s s) t TA"
        by(auto elim: rev_iffD1[OF _ thread_oks_ts_change] cond_action_oks_final_change)

      with tst NormalAction ‹redT_upd s t ta x' m s' have "mthr.redT (?s s) (t, TA) (?s s')"
        using map_redT_updTs[of snd "thr s" "tat"]
        by(auto intro!: mthr.redT.intros simp add: split_def map_prod_def o_def fun_eq_iff)
      moreover note ts_ok' vs'
      moreover from ta = convert_TA_initial (convert_obs_initial TA) have "tao = map NormalAction TAo" by(auto)
      with sc have "non_speculative P vs (llist_of (take n (map NormalAction TAo)))" by simp
      ultimately have "vs_conf P (shr (?s s')) (w_values P vs (take n (map NormalAction TAo)))"
        by(auto dest: redT_wfs_non_speculative_vs_conf)
      thus ?thesis using tao = map NormalAction TAo by(auto)
    next
      case InitialThreadAction
      with redT_normal vs show ?thesis by(auto simp add: take_Cons')
    next
      case ThreadFinishAction
      with redT_normal vs show ?thesis by(auto simp add: take_Cons')
    qed
  next
    case (redT_acquire x l ln)
    have "w_values P vs (take n (map NormalAction (convert_RA ln :: ('addr, 'thread_id) obs_event list))) = vs"
      by(fastforce simp add: convert_RA_not_write take_Cons' dest: in_set_takeD intro!: w_values_no_write_unchanged del: equalityI)
    thus ?thesis using vs redT_acquire by auto 
  qed
qed

lemma if_RedT_non_speculative_invar:
  assumes red: "mthr.if.RedT s ttas s'"
  and tsok: "ts_ok (init_fin_lift wfx) (thr s) (shr s)"
  and sc: "non_speculative P vs (llist_of (concat (map (λ(t, ta). tao) ttas)))"
  and vs: "vs_conf P (shr s) vs"
  shows "ts_ok (init_fin_lift wfx) (thr s') (shr s')" (is ?thesis1)
  and "vs_conf P (shr s') (w_values P vs (concat (map (λ(t, ta). tao) ttas)))" (is ?thesis2)
using red tsok sc vs unfolding mthr.if.RedT_def
proof(induct arbitrary: vs rule: rtrancl3p_converse_induct')
  case refl
  case 1 thus ?case by -
  case 2 thus ?case by simp
next
  case (step s tta s' ttas)
  obtain t ta where tta: "tta = (t, ta)" by(cases tta)

  case 1
  hence sc1: "non_speculative P vs (llist_of tao)"
    and sc2: "non_speculative P (w_values P vs tao) (llist_of (concat (map (λ(t, ta). tao) ttas)))"
    unfolding lconcat_llist_of[symmetric] lmap_llist_of[symmetric] llist.map_comp o_def llist_of.simps llist.map(2) lconcat_LCons tta
    by(simp_all add: non_speculative_lappend list_of_lconcat o_def)
  from if_redT_non_speculative_invar[OF step(2)[unfolded tta] _ sc1] if_redT_non_speculative_vs_conf[OF step(2)[unfolded tta], where vs = vs and n="length tao"] 1 step.hyps(3)[of "w_values P vs tao"] sc2 sc1
  show ?case by simp

  case 2
  hence sc1: "non_speculative P vs (llist_of tao)"
    and sc2: "non_speculative P (w_values P vs tao) (llist_of (concat (map (λ(t, ta). tao) ttas)))"
    unfolding lconcat_llist_of[symmetric] lmap_llist_of[symmetric] llist.map_comp o_def llist_of.simps llist.map(2) lconcat_LCons tta
    by(simp_all add: non_speculative_lappend list_of_lconcat o_def)
  from if_redT_non_speculative_invar[OF step(2)[unfolded tta] _ sc1] if_redT_non_speculative_vs_conf[OF step(2)[unfolded tta], where vs = vs and n="length tao"] 2 step.hyps(4)[of "w_values P vs tao"] sc2 sc1
  show ?case by(simp add: tta o_def)
qed

lemma init_fin_hext_incr:
  assumes "t  (x, m) -ta→i (x', m')"
  and "init_fin_lift wfx t x m"
  and "non_speculative P vs (llist_of tao)"
  and "vs_conf P m vs"
  shows "m  m'"
using assms
by(cases)(auto intro: red_hext_incr)

lemma init_fin_redT_hext_incr:
  assumes "mthr.if.redT s (t, ta) s'"
  and "ts_ok (init_fin_lift wfx) (thr s) (shr s)"
  and "non_speculative P vs (llist_of tao)"
  and "vs_conf P (shr s) vs"
  shows "shr s  shr s'"
using assms
by(cases)(auto dest: init_fin_hext_incr ts_okD)

lemma init_fin_RedT_hext_incr:
  assumes "mthr.if.RedT s ttas s'"
  and "ts_ok (init_fin_lift wfx) (thr s) (shr s)"
  and sc: "non_speculative P vs (llist_of (concat (map (λ(t, ta). tao) ttas)))"
  and vs: "vs_conf P (shr s) vs"
  shows "shr s  shr s'"
using assms
proof(induction rule: mthr.if.RedT_induct')
  case refl thus ?case by simp
next
  case (step ttas s' t ta s'')
  note ts_ok = ‹ts_ok (init_fin_lift wfx) (thr s) (shr s)
  from ‹non_speculative P vs (llist_of (concat (map (λ(t, ta). tao) (ttas @ [(t, ta)]))))
  have ns: "non_speculative P vs (llist_of (concat (map (λ(t, ta). tao) ttas)))"
    and ns': "non_speculative P (w_values P vs (concat (map (λ(t, ta). tao) ttas))) (llist_of tao)"
    by(simp_all add: lappend_llist_of_llist_of[symmetric] non_speculative_lappend del: lappend_llist_of_llist_of)
  from ts_ok ns have "shr s  shr s'" 
    using ‹vs_conf P (shr s) vs by(rule step.IH)
  also have "ts_ok (init_fin_lift wfx) (thr s') (shr s')"
    using ‹mthr.if.RedT s ttas s' ts_ok ns ‹vs_conf P (shr s) vs
    by(rule if_RedT_non_speculative_invar)
  with ‹mthr.if.redT s' (t, ta) s'' 
  have "  shr s''" using ns'
  proof(rule init_fin_redT_hext_incr)
    from ‹mthr.if.RedT s ttas s' ts_ok ns ‹vs_conf P (shr s) vs
    show "vs_conf P (shr s') (w_values P vs (concat (map (λ(t, ta). tao) ttas)))"
      by(rule if_RedT_non_speculative_invar)
  qed
  finally show ?case .
qed

lemma init_fin_red_read_typeable:
  assumes "t  (x, m) -ta→i (x', m')"
  and "init_fin_lift wfx t x m" "NormalAction (ReadMem ad al v)  set tao"
  shows "T. P,m  ad@al : T"
using assms
by cases(auto dest: red_read_typeable)

lemma Ex_new_action_for:
  assumes wf: "wf_syscls P"
  and wfx_start: "ts_ok wfx (thr (start_state f P C M vs)) start_heap"
  and ka: "known_addrs start_tid (f (fst (method P C M)) M (fst (snd (method P C M))) (fst (snd (snd (method P C M)))) (the (snd (snd (snd (method P C M))))) vs)  allocated start_heap"
  and E: "E  ℰ_start f P C M vs status"
  and read: "ra  read_actions E"
  and aloc: "adal  action_loc P E ra"
  and sc: "non_speculative P (λ_. {}) (ltake (enat ra) (lmap snd E))"
  shows "wa. wa  new_actions_for P E adal  wa < ra"
proof -
  let ?obs_prefix = "lift_start_obs start_tid start_heap_obs"
  let ?start_state = "init_fin_lift_state status (start_state f P C M vs)"

  from start_state_vs_conf[OF wf]
  have vs_conf_start: "vs_conf P start_heap (w_values P (λ_. {}) (map NormalAction start_heap_obs))" 
    by(simp add: lift_start_obs_def o_def)

  obtain ad al where adal: "adal = (ad, al)" by(cases adal)
  with read aloc obtain v where ra: "action_obs E ra = NormalAction (ReadMem ad al v)"
    and ra_len: "enat ra < llength E"
    by(cases "lnth E ra")(auto elim!: read_actions.cases actionsE)

  from E obtain E'' where E: "E = lappend (llist_of ?obs_prefix) E''"
    and E'': "E''  mthr.if.ℰ ?start_state" by(auto)
  from E'' obtain E' where E': "E'' = lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E')"
    and τRuns: "mthr.if.mthr.Runs ?start_state E'" by(rule mthr.if.ℰ.cases)

  have ra_len': "length ?obs_prefix  ra"
  proof(rule ccontr)
    assume "¬ ?thesis"
    hence "ra < length ?obs_prefix" by simp
    moreover with ra ra_len E obtain ra' ad al v 
      where "start_heap_obs ! ra' = ReadMem ad al v" "ra' < length start_heap_obs"
      by(cases ra)(auto simp add: lnth_LCons lnth_lappend1 action_obs_def lift_start_obs_def)
    ultimately have "ReadMem ad al v  set start_heap_obs" unfolding in_set_conv_nth by blast
    thus False by(simp add: start_heap_obs_not_Read)
  qed
  let ?n = "length ?obs_prefix"
  from ra ra_len ra_len' E have "enat (ra - ?n) < llength E''"
    and ra_obs: "action_obs E'' (ra - ?n) = NormalAction (ReadMem ad al v)"
    by(cases "llength E''", auto simp add: action_obs_def lnth_lappend2)
  
  from τRuns ‹enat (ra - ?n) < llength E'' obtain ra_m ra_n t_ra ta_ra 
    where E_ra: "lnth E'' (ra - ?n) = (t_ra, ta_rao ! ra_n)"
    and ra_n: "ra_n < length ta_rao" and ra_m: "enat ra_m < llength E'"
    and ra_conv: "ra - ?n = (i<ra_m. length snd (lnth E' i)o) + ra_n"
    and E'_ra_m: "lnth E' ra_m = (t_ra, ta_ra)"
    unfolding E' by(rule mthr.if.actions_ℰE_aux)
    
  let ?E' = "ldropn (Suc ra_m) E'"
    
  have E'_unfold: "E' = lappend (ltake (enat ra_m) E') (LCons (lnth E' ra_m) ?E')"
    unfolding ldropn_Suc_conv_ldropn[OF ra_m] by simp
  hence "mthr.if.mthr.Runs ?start_state (lappend (ltake (enat ra_m) E') (LCons (lnth E' ra_m) ?E'))"
    using τRuns by simp
  then obtain σ' where σ_σ': "mthr.if.mthr.Trsys ?start_state (list_of (ltake (enat ra_m) E')) σ'"
    and τRuns': "mthr.if.mthr.Runs σ' (LCons (lnth E' ra_m) ?E')"
    by(rule mthr.if.mthr.Runs_lappendE) simp
  from τRuns' obtain σ'' where red_ra: "mthr.if.redT σ' (t_ra, ta_ra) σ''"
    and τRuns'': "mthr.if.mthr.Runs σ'' ?E'"
    unfolding E'_ra_m by cases

  from E_ra ra_n ra_obs have "NormalAction (ReadMem ad al v)  set ta_rao"
    by(auto simp add: action_obs_def in_set_conv_nth)
  with red_ra obtain x_ra x'_ra m'_ra 
    where red'_ra: "mthr.init_fin t_ra (x_ra, shr σ') ta_ra (x'_ra, m'_ra)"
    and σ'': "redT_upd σ' t_ra ta_ra x'_ra m'_ra σ''"
    and ts_t_a: "thr σ' t_ra = (x_ra, no_wait_locks)"
    by cases auto
  from red'_ra ‹NormalAction (ReadMem ad al v)  set ta_rao
  obtain ta'_ra X_ra X'_ra
    where x_ra: "x_ra = (Running, X_ra)"
    and x'_ra: "x'_ra = (Running, X'_ra)"
    and ta_ra: "ta_ra = convert_TA_initial (convert_obs_initial ta'_ra)"
    and red''_ra: "t_ra  (X_ra, shr σ') -ta'_ra (X'_ra, m'_ra)"
    by cases fastforce+

  from ‹NormalAction (ReadMem ad al v)  set ta_rao ta_ra 
  have "ReadMem ad al v  set ta'_rao" by auto

  from wfx_start have wfx_start: "ts_ok (init_fin_lift wfx) (thr ?start_state) (shr ?start_state)"
    by(simp add: start_state_def split_beta)

  from sc ra_len'
  have "non_speculative P (w_values P (λ_. {}) (map snd ?obs_prefix))
    (lmap snd (ltake (enat (ra - ?n)) (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E'))))"
    unfolding E E' by(simp add: ltake_lappend2 lmap_lappend_distrib non_speculative_lappend)
  also note ra_conv also note plus_enat_simps(1)[symmetric]
  also have "enat (i<ra_m. length snd (lnth E' i)o) = (i<ra_m. enat (length snd (lnth E' i)o))"
    by(subst sum_hom[symmetric])(simp_all add: zero_enat_def)
  also have " = (i<ra_m. llength (lnth (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E') i))"
    using ra_m by-(rule sum.cong[OF refl], simp add: le_less_trans[where y="enat ra_m"] split_beta)
  also note ltake_plus_conv_lappend also note lconcat_ltake[symmetric]
  also note lmap_lappend_distrib
  also note non_speculative_lappend
  finally have "non_speculative P (w_values P (λ_. {}) (map snd ?obs_prefix)) (lmap snd (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) (llist_of (list_of (ltake (enat ra_m) E'))))))"
    by(simp add: split_def)
  hence sc': "non_speculative P (w_values P (λ_. {}) (map snd ?obs_prefix)) (llist_of (concat (map (λ(t, ta). tao) (list_of (ltake (enat ra_m) E')))))"
    unfolding lmap_lconcat llist.map_comp o_def lconcat_llist_of[symmetric] lmap_llist_of[symmetric]
    by(simp add: split_beta o_def)

  from vs_conf_start have vs_conf_start: "vs_conf P (shr ?start_state) (w_values P (λ_. {}) (map snd ?obs_prefix))"
    by(simp add:init_fin_lift_state_conv_simps start_state_def split_beta lift_start_obs_def o_def)
  with σ_σ' wfx_start sc' have "ts_ok (init_fin_lift wfx) (thr σ') (shr σ')"
    unfolding mthr.if.RedT_def[symmetric] by(rule if_RedT_non_speculative_invar)
  with ts_t_a have "wfx t_ra X_ra (shr σ')" unfolding x_ra by(auto dest: ts_okD)

  with red''_ra ‹ReadMem ad al v  set ta'_rao
  obtain T' where type_adal: "P,shr σ'  ad@al : T'" by(auto dest: red_read_typeable)

  from sc ra_len' have "non_speculative P (λ_. {}) (llist_of (map snd ?obs_prefix))"
    unfolding E by(simp add: ltake_lappend2 lmap_lappend_distrib non_speculative_lappend)
  with sc' have sc'': "non_speculative P (λ_. {}) (llist_of (map snd (lift_start_obs start_tid start_heap_obs) @ concat (map (λ(t, ta). tao) (list_of (ltake (enat ra_m) E')))))"
    by(simp add: lappend_llist_of_llist_of[symmetric] non_speculative_lappend del: lappend_llist_of_llist_of)

  from σ_σ' red_ra ‹NormalAction (ReadMem ad al v)  set ta_rao sc'' ka
  show "wa. wa  new_actions_for P E adal  wa < ra"
    unfolding mthr.if.RedT_def[symmetric]
  proof(cases rule: read_ex_NewHeapElem)
    case (start CTn)
    then obtain n where n: "start_heap_obs ! n = NewHeapElem ad CTn" 
      and len: "n < length start_heap_obs"
      unfolding in_set_conv_nth by blast
    from len have "Suc n  actions E" unfolding E by(simp add: actions_def enat_less_enat_plusI)
    moreover
    from σ_σ' have hext: "start_heap  shr σ'" unfolding mthr.if.RedT_def[symmetric]
      using wfx_start sc' vs_conf_start
      by(auto dest!: init_fin_RedT_hext_incr simp add: start_state_def split_beta init_fin_lift_state_conv_simps)
    
    from start have "typeof_addr start_heap ad = CTn"
      by(auto dest: NewHeapElem_start_heap_obsD[OF wf])
    with hext have "typeof_addr (shr σ') ad = CTn" by(rule typeof_addr_hext_mono)
    with type_adal have "adal  action_loc P E (Suc n)" using n len unfolding E adal
      by cases(auto simp add: action_obs_def lnth_lappend1 lift_start_obs_def)
    moreover have "is_new_action (action_obs E (Suc n))" using n len unfolding E
      by(simp add: action_obs_def lnth_lappend1 lift_start_obs_def)
    ultimately have "Suc n  new_actions_for P E adal" by(rule new_actionsI)
    moreover have "Suc n < ra" using ra_len' len by(simp)
    ultimately show ?thesis by blast
  next
    case (Red ttas' s'' t' ta' s''' ttas'' CTn)
    
    from ‹NormalAction (NewHeapElem ad CTn)  set ta'o
    obtain obs obs' where obs: "ta'o = obs @ NormalAction (NewHeapElem ad CTn) # obs'"
      by(auto dest: split_list)
    
    let ?wa = "?n + length (concat (map (λ(t, ta). tao) ttas')) + length obs"
    have "enat (length (concat (map (λ(t, ta). tao) ttas')) + length obs) < enat (length (concat (map (λ(t, ta). tao) (ttas' @ [(t', ta')]))))"
      using obs by simp
    also have " = llength (lconcat (lmap llist_of (lmap (λ(t, ta). tao) (llist_of (ttas' @ [(t', ta')])))))"
      by(simp del: map_map map_append add: lconcat_llist_of)
    also have "  llength (lconcat (lmap (λ(t, ta). llist_of tao) (llist_of (ttas' @ (t', ta') # ttas''))))"
      by(auto simp add: o_def split_def intro: lprefix_llist_ofI intro!: lprefix_lconcatI lprefix_llength_le)
    also note len_less = calculation
    have "  (i<ra_m. llength (lnth (lmap (λ(t, ta). llist_of tao) E') i))"
      unfolding ‹list_of (ltake (enat ra_m) E') = ttas' @ (t', ta') # ttas''[symmetric]
      by(simp add: ltake_lmap[symmetric] lconcat_ltake del: ltake_lmap)
    also have " = enat (i<ra_m. length snd (lnth E' i)o)" using ra_m
      by(subst sum_hom[symmetric, where f="enat"])(auto intro: sum.cong simp add: zero_enat_def less_trans[where y="enat ra_m"] split_beta)
    also have "  enat (ra - ?n)" unfolding ra_conv by simp
    finally have enat_length: "enat (length (concat (map (λ(t, ta). tao) ttas')) + length obs) < enat (ra - length (lift_start_obs start_tid start_heap_obs))" .
    then have wa_ra: "?wa < ra" by simp
    with ra_len have "?wa  actions E" by(cases "llength E")(simp_all add: actions_def)
    moreover
    from ‹mthr.if.redT s'' (t', ta') s''' ‹NormalAction (NewHeapElem ad CTn)  set ta'o
    obtain x_wa x_wa' where ts''t': "thr s'' t' = (x_wa, no_wait_locks)"
      and red_wa: "mthr.init_fin t' (x_wa, shr s'') ta' (x_wa', shr s''')"
      by(cases) fastforce+

    from sc'
    have ns: "non_speculative P (w_values P (λ_. {}) (map snd ?obs_prefix)) (llist_of (concat (map (λ(t, ta). tao) ttas')))"
      and ns': "non_speculative P (w_values P (w_values P (λ_. {}) (map snd ?obs_prefix)) (concat (map (λ(t, ta). tao) ttas'))) (llist_of ta'o)"
      and ns'': "non_speculative P (w_values P (w_values P (w_values P (λ_. {}) (map snd ?obs_prefix)) (concat (map (λ(t, ta). tao) ttas'))) ta'o) (llist_of (concat (map (λ(t, ta). tao) ttas'')))"
      unfolding ‹list_of (ltake (enat ra_m) E') = ttas' @ (t', ta') # ttas''
      by(simp_all add: lappend_llist_of_llist_of[symmetric] lmap_lappend_distrib non_speculative_lappend del: lappend_llist_of_llist_of)
    from ‹mthr.if.RedT ?start_state ttas' s'' wfx_start ns
    have ts_ok'': "ts_ok (init_fin_lift wfx) (thr s'') (shr s'')"
      using vs_conf_start by(rule if_RedT_non_speculative_invar)
    with ts''t' have wfxt': "wfx t' (snd x_wa) (shr s'')" by(cases x_wa)(auto dest: ts_okD)

    {
      have "action_obs E ?wa = 
        snd (lnth (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E')) (length (concat (map (λ(t, y). yo) ttas')) + length obs))"
        unfolding E E' by(simp add: action_obs_def lnth_lappend2)
      also from enat_length ‹enat (ra - ?n) < llength E''
      have " = lnth (lconcat (lmap (λ(t, ta). llist_of tao) E')) (length (concat (map (λ(t, y). yo) ttas')) + length obs)"
        unfolding E'
        by(subst lnth_lmap[symmetric, where f=snd])(erule (1) less_trans, simp add: lmap_lconcat llist.map_comp split_def o_def)
      also from len_less
      have "enat (length (concat (map (λ(t, ta). tao) ttas')) + length obs) < llength (lconcat (ltake (enat ra_m) (lmap (λ(t, ta). llist_of tao) E')))"
        unfolding ‹list_of (ltake (enat ra_m) E') = ttas' @ (t', ta') # ttas''[symmetric]
        by(simp add: ltake_lmap[symmetric] del: ltake_lmap)
      note lnth_lconcat_ltake[OF this, symmetric]
      also note ltake_lmap
      also have "ltake (enat ra_m) E' = llist_of (list_of (ltake (enat ra_m) E'))" by(simp)
      also note ‹list_of (ltake (enat ra_m) E') = ttas' @ (t', ta') # ttas''
      also note lmap_llist_of also have "(λ(t, ta). llist_of tao) = llist_of  (λ(t, ta). tao)"
        by(simp add: o_def split_def)
      also note map_map[symmetric] also note lconcat_llist_of
      also note lnth_llist_of 
      also have "concat (map (λ(t, ta). tao) (ttas' @ (t', ta') # ttas'')) ! (length (concat (map (λ(t, ta). tao) ttas')) + length obs) = NormalAction (NewHeapElem ad CTn)"
        by(simp add: nth_append obs)
      finally have "action_obs E ?wa = NormalAction (NewHeapElem ad CTn)" .
    }
    note wa_obs = this
    
    from ‹mthr.if.RedT ?start_state ttas' s'' wfx_start ns vs_conf_start
    have vs'': "vs_conf P (shr s'') (w_values P (w_values P (λ_. {}) (map snd ?obs_prefix)) (concat (map (λ(t, ta). tao) ttas')))"
      by(rule if_RedT_non_speculative_invar)
    from if_redT_non_speculative_vs_conf[OF ‹mthr.if.redT s'' (t', ta') s''' ts_ok'' _ vs'', of "length ta'o"] ns'
    have vs''': "vs_conf P (shr s''') (w_values P (w_values P (w_values P (λ_. {}) (map snd ?obs_prefix)) (concat (map (λ(t, ta). tao) ttas'))) ta'o)"
      by simp
    
    from ‹mthr.if.redT s'' (t', ta') s''' ts_ok'' ns' vs''
    have "ts_ok (init_fin_lift wfx) (thr s''') (shr s''')"
      by(rule if_redT_non_speculative_invar)
    with ‹mthr.if.RedT s''' ttas'' σ'
    have hext: "shr s'''  shr σ'" using ns'' vs'''
      by(rule init_fin_RedT_hext_incr)

    from red_wa have "typeof_addr (shr s''') ad = CTn"
      using wfxt' ‹NormalAction (NewHeapElem ad CTn)  set ta'o by cases(auto dest: red_NewHeapElemD)
    with hext have "typeof_addr (shr σ') ad = CTn" by(rule typeof_addr_hext_mono)
    with type_adal have "adal  action_loc P E ?wa" using wa_obs unfolding E adal
      by cases (auto simp add: action_obs_def lnth_lappend1 lift_start_obs_def)
    moreover have "is_new_action (action_obs E ?wa)" using wa_obs by simp
    ultimately have "?wa  new_actions_for P E adal" by(rule new_actionsI)
    thus ?thesis using wa_ra by blast
  qed
qed

lemma executions_sc_hb:
  assumes "wf_syscls P"
  and "ts_ok wfx (thr (start_state f P C M vs)) start_heap"
  and "known_addrs start_tid (f (fst (method P C M)) M (fst (snd (method P C M))) (fst (snd (snd (method P C M)))) (the (snd (snd (snd (method P C M))))) vs)  allocated start_heap"
  shows
  "executions_sc_hb (ℰ_start f P C M vs status) P"
  (is "executions_sc_hb ?E P")
proof
  fix E a adal a'
  assume "E  ?E" "a  new_actions_for P E adal" "a'  new_actions_for P E adal"
  thus "a = a'" by(rule ℰ_new_actions_for_unique)
next
  fix E ra adal
  assume "E  ?E" "ra  read_actions E" "adal  action_loc P E ra" 
    and "non_speculative P (λ_. {}) (ltake (enat ra) (lmap snd E))"
  with assms show "wa. wa  new_actions_for P E adal  wa < ra"
    by(rule Ex_new_action_for)
qed

lemma executions_aux:
  assumes wf: "wf_syscls P"
  and wfx_start: "ts_ok wfx (thr (start_state f P C M vs)) start_heap" (is "ts_ok wfx (thr ?start_state) _")
  and ka: "known_addrs start_tid (f (fst (method P C M)) M (fst (snd (method P C M))) (fst (snd (snd (method P C M)))) (the (snd (snd (snd (method P C M))))) vs)  allocated start_heap"
  shows "executions_aux (ℰ_start f P C M vs status) P"
  (is "executions_aux ?ℰ P")
proof
  fix E a adal a'
  assume "E  ?ℰ" "a  new_actions_for P E adal" "a'  new_actions_for P E adal"
  thus "a = a'" by(rule ℰ_new_actions_for_unique)
next
  fix E ws r adal
  assume E: "E  ?ℰ"
    and wf_exec: "P  (E, ws) " 
    and read: "r  read_actions E" "adal  action_loc P E r"
    and sc: "a. a < r; a  read_actions E  P,E  a ↝mrw ws a"

  interpret jmm: executions_sc_hb ?ℰ P
    using wf wfx_start ka by(rule executions_sc_hb)

  from E wf_exec sc
  have "ta_seq_consist P Map.empty (ltake (enat r) (lmap snd E))"
    unfolding ltake_lmap by(rule jmm.ta_seq_consist_mrwI) simp
  hence "non_speculative P (λ_. {}) (ltake (enat r) (lmap snd E))"
    by(rule ta_seq_consist_into_non_speculative) simp
  with wf wfx_start ka E read
  have "i. i  new_actions_for P E adal  i < r"
    by(rule Ex_new_action_for)
  thus "i<r. i  new_actions_for P E adal" by blast
qed

lemma drf:
  assumes cut_and_update:
    "if.cut_and_update
       (init_fin_lift_state status (start_state f P C M vs))
       (mrw_values P Map.empty (map snd (lift_start_obs start_tid start_heap_obs)))"
    (is "if.cut_and_update ?start_state (mrw_values _ _ (map _ ?start_heap_obs))")
  and wf: "wf_syscls P"
  and wfx_start: "ts_ok wfx (thr (start_state f P C M vs)) start_heap"
  and ka: "known_addrs start_tid (f (fst (method P C M)) M (fst (snd (method P C M))) (fst (snd (snd (method P C M)))) (the (snd (snd (snd (method P C M))))) vs)  allocated start_heap"
  shows "drf (ℰ_start f P C M vs status) P" (is "drf ?ℰ _")
proof -
  interpret jmm: executions_sc_hb "?ℰ" P
    using wf wfx_start ka by(rule executions_sc_hb)

  let ?n = "length ?start_heap_obs"
  let ?ℰ' = "lappend (llist_of ?start_heap_obs) ` mthr.if.ℰ ?start_state"

  show ?thesis 
  proof
    fix E ws r
    assume E: "E  ?ℰ'"
      and wf: "P  (E, ws) "
      and mrw: "a.  a < r; a  read_actions E   P,E  a ↝mrw ws a"
    show "E'?ℰ'. ws'. P  (E', ws')   ltake (enat r) E = ltake (enat r) E' 
                           sequentially_consistent P (E', ws') 
                           action_tid E r = action_tid E' r  action_obs E r  action_obs E' r 
                           (r  actions E  r  actions E')"
    proof(cases "r'. r'  read_actions E  r  r'")
      case False
      have "sequentially_consistent P (E, ws)"
      proof(rule sequentially_consistentI)
        fix a
        assume "a  read_actions E"
        with False have "a < r" by auto
        thus "P,E  a ↝mrw ws a" using a  read_actions E by(rule mrw)
      qed
      moreover have "action_obs E r  action_obs E r" by(rule sim_action_refl)
      ultimately show ?thesis using wf E by blast
    next
      case True
      let ?P = "λr'. r'  read_actions E  r  r'"
      let ?r = "Least ?P"
      from True obtain r' where r': "?P r'" by blast
      hence r: "?P ?r" by(rule LeastI)
      {
        fix a
        assume "a < ?r" "a  read_actions E"
        have "P,E  a ↝mrw ws a"
        proof(cases "a < r")
          case True
          thus ?thesis using a  read_actions E by(rule mrw)
        next
          case False
          with a  read_actions E have "?P a" by simp
          hence "?r  a" by(rule Least_le)
          with a < ?r have False by simp
          thus ?thesis ..
        qed }
      note mrw' = this

      from E obtain E'' where E: "E = lappend (llist_of ?start_heap_obs) E''"
        and E'': "E''  mthr.if.ℰ ?start_state" by auto

      from E'' obtain E' where E': "E'' = lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E')"
        and τRuns: "mthr.if.mthr.Runs ?start_state E'"
        by(rule mthr.if.ℰ.cases)

      have r_len: "length ?start_heap_obs  ?r"
      proof(rule ccontr)
        assume "¬ ?thesis"
        hence "?r < length ?start_heap_obs" by simp
        moreover with r E obtain t ad al v where "?start_heap_obs ! ?r = (t, NormalAction (ReadMem ad al v))"
          by(cases "?start_heap_obs ! ?r")(fastforce elim!: read_actions.cases simp add: actions_def action_obs_def lnth_lappend1)
        ultimately have "(t, NormalAction (ReadMem ad al v))  set ?start_heap_obs" unfolding in_set_conv_nth by blast
        thus False by(auto simp add: start_heap_obs_not_Read)
      qed
      let ?n = "length ?start_heap_obs"
      from r r_len E have r: "?r - ?n  read_actions E''"
        by(fastforce elim!: read_actions.cases simp add: actions_lappend action_obs_def lnth_lappend2 elim: actionsE intro: read_actions.intros)
      
      from r have "?r - ?n  actions E''" by(auto)
      hence "enat (?r - ?n) < llength E''" by(rule actionsE)
      with τRuns obtain r_m r_n t_r ta_r 
        where E_r: "lnth E'' (?r - ?n) = (t_r, ta_ro ! r_n)"
        and r_n: "r_n < length ta_ro" and r_m: "enat r_m < llength E'"
        and r_conv: "?r - ?n = (i<r_m. length snd (lnth E' i)o) + r_n"
        and E'_r_m: "lnth E' r_m = (t_r, ta_r)"
        unfolding E' by(rule mthr.if.actions_ℰE_aux)

      let ?E' = "ldropn (Suc r_m) E'"
      let ?r_m_E' = "ltake (enat r_m) E'"
      have E'_unfold: "E' = lappend (ltake (enat r_m) E') (LCons (lnth E' r_m) ?E')"
        unfolding ldropn_Suc_conv_ldropn[OF r_m] by simp
      hence "mthr.if.mthr.Runs ?start_state (lappend ?r_m_E' (LCons (lnth E' r_m) ?E'))"
        using τRuns by simp
      then obtain σ' where σ_σ': "mthr.if.mthr.Trsys ?start_state (list_of ?r_m_E') σ'"
        and τRuns': "mthr.if.mthr.Runs σ' (LCons (lnth E' r_m) ?E')"
        by(rule mthr.if.mthr.Runs_lappendE) simp
      from τRuns' obtain σ''' where red_ra: "mthr.if.redT σ' (t_r, ta_r) σ'''"
        and τRuns'': "mthr.if.mthr.Runs σ''' ?E'"
        unfolding E'_r_m by cases

      let ?vs = "mrw_values P Map.empty (map snd ?start_heap_obs)"
      { fix a
        assume "enat a < enat ?r"
          and "a  read_actions E"
        have "a < r"
        proof(rule ccontr)
          assume "¬ a < r"
          with a  read_actions E have "?P a" by simp
          hence "?r  a" by(rule Least_le)
          with ‹enat a < enat ?r show False by simp
        qed
        hence "P,E  a ↝mrw ws a" using a  read_actions E by(rule mrw) }
      with E  ?ℰ' wf have "ta_seq_consist P Map.empty (lmap snd (ltake (enat ?r) E))"
        by(rule jmm.ta_seq_consist_mrwI)

      hence start_sc: "ta_seq_consist P Map.empty (llist_of (map snd ?start_heap_obs))"
        and "ta_seq_consist P ?vs (lmap snd (ltake (enat (?r - ?n)) E''))"
        using ?n  ?r unfolding E ltake_lappend lmap_lappend_distrib
        by(simp_all add: ta_seq_consist_lappend o_def)

      note this(2) also from r_m
      have r_m_sum_len_eq: "(i<r_m. llength (lnth (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E') i)) = enat (i<r_m. length snd (lnth E' i)o)"
        by(subst sum_hom[symmetric, where f=enat])(auto simp add: zero_enat_def split_def less_trans[where y="enat r_m"] intro: sum.cong)
      hence "ltake (enat (?r - ?n)) E'' = 
            lappend (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) ?r_m_E')) 
                    (ltake (enat r_n) (ldrop (enat (i<r_m. length snd (lnth E' i)o)) E''))"
        unfolding ltake_lmap[symmetric] lconcat_ltake r_conv plus_enat_simps(1)[symmetric] ltake_plus_conv_lappend
        unfolding E' by simp
      finally have "ta_seq_consist P ?vs (lmap snd (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) ?r_m_E')))"
        and sc_ta_r: "ta_seq_consist P (mrw_values P ?vs (map snd (list_of (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) ?r_m_E'))))) (lmap snd (ltake (enat r_n) (ldropn (i<r_m. length snd (lnth E' i)o) E'')))"
        unfolding lmap_lappend_distrib by(simp_all add: ta_seq_consist_lappend split_def ldrop_enat)
      note this(1) also
      have "lmap snd (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) (ltake (enat r_m) E')))
            = llist_of (concat (map (λ(t, ta). tao) (list_of ?r_m_E')))"
        unfolding lmap_lconcat llist.map_comp o_def split_def lconcat_llist_of[symmetric] map_map lmap_llist_of[symmetric]
        by simp
      finally have "ta_seq_consist P ?vs (llist_of (concat (map (λ(t, ta). tao) (list_of ?r_m_E'))))" .
      from if.sequential_completion[OF cut_and_update ta_seq_consist_convert_RA σ_σ'[folded mthr.if.RedT_def] this red_ra]
      obtain ta' ttas' 
        where "mthr.if.mthr.Runs σ' (LCons (t_r, ta') ttas')"
        and sc: "ta_seq_consist P (mrw_values P Map.empty (map snd ?start_heap_obs)) 
                   (lconcat (lmap (λ(t, ta). llist_of tao) (lappend (llist_of (list_of ?r_m_E')) (LCons (t_r, ta') ttas'))))"
          and eq_ta: "eq_upto_seq_inconsist P ta_ro ta'o (mrw_values P ?vs (concat (map (λ(t, ta). tao) (list_of ?r_m_E'))))"
          by blast

      let ?E_sc' = "lappend (llist_of (list_of ?r_m_E')) (LCons (t_r, ta') ttas')"
      let ?E_sc'' = "lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) ?E_sc')"
      let ?E_sc = "lappend (llist_of ?start_heap_obs) ?E_sc''"

      from σ_σ' ‹mthr.if.mthr.Runs σ' (LCons (t_r, ta') ttas')
      have "mthr.if.mthr.Runs ?start_state ?E_sc'" by(rule mthr.if.mthr.Trsys_into_Runs)
      hence "?E_sc''  mthr.if.ℰ ?start_state" by(rule mthr.if.ℰ.intros)
      hence "?E_sc  ?ℰ" by(rule imageI)
      moreover from ?E_sc''  mthr.if.ℰ ?start_state
      have tsa_ok: "thread_start_actions_ok ?E_sc" by(rule thread_start_actions_ok_init_fin) 
        
      from sc have "ta_seq_consist P Map.empty (lmap snd ?E_sc)"
        by(simp add: lmap_lappend_distrib o_def lmap_lconcat llist.map_comp split_def ta_seq_consist_lappend start_sc)
      from ta_seq_consist_imp_sequentially_consistent[OF tsa_ok jmm.ℰ_new_actions_for_fun[OF ?E_sc  ?ℰ] this]
      obtain ws_sc where "sequentially_consistent P (?E_sc, ws_sc)"
        and "P  (?E_sc, ws_sc) " unfolding start_heap_obs_def[symmetric] by iprover
      moreover {
        have enat_sum_r_m_eq: "enat (i<r_m. length snd (lnth E' i)o) = llength (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) ?r_m_E'))"
          by(auto intro: sum.cong simp add: less_trans[OF _ r_m] lnth_ltake llength_lconcat_lfinite_conv_sum sum_hom[symmetric, where f=enat] zero_enat_def[symmetric] split_beta)
        also have "  llength E''" unfolding E'
          by(blast intro: lprefix_llength_le lprefix_lconcatI lmap_lprefix)
        finally have r_m_E: "ltake (enat (?n + (i<r_m. length snd (lnth E' i)o))) E = ltake (enat (?n + (i<r_m. length snd (lnth E' i)o))) ?E_sc"
          by(simp add: ltake_lappend lappend_eq_lappend_conv lmap_lappend_distrib r_m_sum_len_eq ltake_lmap[symmetric] min_def zero_enat_def[symmetric] E E' lconcat_ltake ltake_all del: ltake_lmap)

        have drop_r_m_E: "ldropn (?n + (i<r_m. length snd (lnth E' i)o)) E = lappend (llist_of (map (Pair t_r) ta_ro)) (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) (ldropn (Suc r_m) E')))"
          (is "_ = ?drop_r_m_E") using E'_r_m unfolding E E'
          by(subst (2) E'_unfold)(simp add: ldropn_lappend2 lmap_lappend_distrib enat_sum_r_m_eq[symmetric])

        have drop_r_m_E_sc: "ldropn (?n + (i<r_m. length snd (lnth E' i)o)) ?E_sc =
          lappend (llist_of (map (Pair t_r) ta'o)) (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) ttas'))"
          by(simp add: ldropn_lappend2 lmap_lappend_distrib enat_sum_r_m_eq[symmetric])

        let ?vs_r_m = "mrw_values P ?vs (map snd (list_of (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) ?r_m_E'))))"
        note sc_ta_r also
        from drop_r_m_E have "ldropn (i<r_m. length snd (lnth E' i)o) E'' = ?drop_r_m_E"
          unfolding E by(simp add: ldropn_lappend2)
        also have "lmap snd (ltake (enat r_n) ) = llist_of (take r_n ta_ro)" using r_n
          by(simp add: ltake_lappend lmap_lappend_distrib ltake_lmap[symmetric] take_map o_def zero_enat_def[symmetric] del: ltake_lmap)
        finally have sc_ta_r: "ta_seq_consist P ?vs_r_m (llist_of (take r_n ta_ro))" .
        note eq_ta
        also have "ta_ro = take r_n ta_ro @ drop r_n ta_ro" by simp
        finally have "eq_upto_seq_inconsist P (take r_n ta_ro @ drop r_n ta_ro) ta'o ?vs_r_m"
          by(simp add: list_of_lconcat split_def o_def map_concat)
        from eq_upto_seq_inconsist_appendD[OF this sc_ta_r]
        have r_n': "r_n  length ta'o"
          and take_r_n_eq: "take r_n ta'o = take r_n ta_ro"
          and eq_r_n: "eq_upto_seq_inconsist P (drop r_n ta_ro) (drop r_n ta'o) (mrw_values P ?vs_r_m (take r_n ta_ro))"
          using r_n by(simp_all add: min_def)
        from r_conv ?n  ?r have r_conv': "?r = (?n + (i<r_m. length snd (lnth E' i)o)) + r_n" by simp
        from r_n' r_n take_r_n_eq r_m_E drop_r_m_E drop_r_m_E_sc
        have take_r'_eq: "ltake (enat ?r) E = ltake (enat ?r) ?E_sc" unfolding r_conv'
          apply(subst (1 2) plus_enat_simps(1)[symmetric])
          apply(subst (1 2) ltake_plus_conv_lappend)
          apply(simp add: lappend_eq_lappend_conv ltake_lappend1 ldrop_enat take_map)
          done
        hence take_r_eq: "ltake (enat r) E = ltake (enat r) ?E_sc"
          by(rule ltake_eq_ltake_antimono)(simp add: ?P ?r)
        
        from eq_r_n Cons_nth_drop_Suc[OF r_n, symmetric]
        have "drop r_n ta'o  []" by(auto simp add: eq_upto_seq_inconsist_simps)
        hence r_n': "r_n < length ta'o" by simp
        hence eq_r_n: "ta_ro ! r_n  ta'o ! r_n"
          using eq_r_n Cons_nth_drop_Suc[OF r_n, symmetric] Cons_nth_drop_Suc[OF r_n', symmetric]
          by(simp add: eq_upto_seq_inconsist_simps split: action.split_asm obs_event.split_asm if_split_asm)
        obtain tid_eq: "action_tid E r = action_tid ?E_sc r" 
          and obs_eq: "action_obs E r  action_obs ?E_sc r"
        proof(cases "r < ?r")
          case True
          { from True have "action_tid E r = action_tid (ltake (enat ?r) E) r"
              by(simp add: action_tid_def lnth_ltake)
            also note take_r'_eq
            also have "action_tid (ltake (enat ?r) ?E_sc) r = action_tid ?E_sc r"
              using True by(simp add: action_tid_def lnth_ltake)
            finally have "action_tid E r = action_tid ?E_sc r" . }
          moreover
          { from True have "action_obs E r = action_obs (ltake (enat ?r) E) r"
              by(simp add: action_obs_def lnth_ltake)
            also note take_r'_eq
            also have "action_obs (ltake (enat ?r) ?E_sc) r = action_obs ?E_sc r"
              using True by(simp add: action_obs_def lnth_ltake)
            finally have "action_obs E r  action_obs ?E_sc r" by simp }
          ultimately show thesis by(rule that)
        next
          case False
          with ?P ?r have r_eq: "r = ?r" by simp
          hence "lnth E r = (t_r, ta_ro ! r_n)" using E_r r_conv' E by(simp add: lnth_lappend2)
          moreover have "lnth ?E_sc r = (t_r, ta'o ! r_n)" using ?n  ?r r_n'
            by(subst r_eq)(simp add: r_conv lnth_lappend2 lmap_lappend_distrib enat_sum_r_m_eq[symmetric] lnth_lappend1 del: length_lift_start_obs)
          ultimately have "action_tid E r = action_tid ?E_sc r" "action_obs E r  action_obs ?E_sc r"
            using eq_r_n by(simp_all add: action_tid_def action_obs_def)
          thus thesis by(rule that)
        qed
        
        have "enat r < enat ?n + llength (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) (lappend ?r_m_E' (LCons (t_r, ta') LNil))))"
          using ?P ?r r_n' unfolding lmap_lappend_distrib
          by(simp add: enat_sum_r_m_eq[symmetric] r_conv')
        also have "llength (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) (lappend ?r_m_E' (LCons (t_r, ta') LNil))))  llength ?E_sc''"
          by(rule lprefix_llength_le[OF lprefix_lconcatI])(simp add: lmap_lprefix)
        finally have "r  actions ?E_sc" by(simp add: actions_def add_left_mono)
        note this tid_eq obs_eq take_r_eq }
      ultimately show ?thesis by blast
    qed
  qed(rule ℰ_new_actions_for_unique)
qed

lemma sc_legal:
  assumes hb_completion:
    "if.hb_completion (init_fin_lift_state status (start_state f P C M vs)) (lift_start_obs start_tid start_heap_obs)"
    (is "if.hb_completion ?start_state ?start_heap_obs")
  and wf: "wf_syscls P"
  and wfx_start: "ts_ok wfx (thr (start_state f P C M vs)) start_heap"
  and ka: "known_addrs start_tid (f (fst (method P C M)) M (fst (snd (method P C M))) (fst (snd (snd (method P C M)))) (the (snd (snd (snd (method P C M))))) vs)  allocated start_heap"
  shows "sc_legal (ℰ_start f P C M vs status) P"
  (is "sc_legal ?ℰ P")
proof -
  interpret jmm: executions_sc_hb ?ℰ P
    using wf wfx_start ka by(rule executions_sc_hb)

  interpret jmm: executions_aux ?ℰ P
    using wf wfx_start ka by(rule executions_aux)

  show ?thesis
  proof
    fix E ws r
    assume E: "E  ?ℰ" and wf_exec: "P  (E, ws) "
      and mrw: "a. a < r; a  read_actions E  P,E  a ↝mrw ws a"


    from E obtain E'' where E: "E = lappend (llist_of ?start_heap_obs) E''"
      and E'': "E''  mthr.if.ℰ ?start_state" by auto
    
    from E'' obtain E' where E': "E'' = lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E')"
      and τRuns: "mthr.if.mthr.Runs ?start_state E'"
      by(rule mthr.if.ℰ.cases)
    
    show "E'?ℰ. ws'. P  (E', ws')   ltake (enat r) E = ltake (enat r) E' 
                         (aread_actions E'. if a < r then ws' a = ws a else P,E'  ws' a ≤hb a) 
                         action_tid E' r = action_tid E r 
                         (if r  read_actions E then sim_action else (=)) (action_obs E' r) (action_obs E r) 
                         (r  actions E  r  actions E')"
      (is "E'?ℰ. ws'. _  ?same E'  ?read E' ws'  ?tid E'  ?obs E'  ?actions E'")
    proof(cases "r < length ?start_heap_obs")
      case True

      from if.hb_completion_Runs[OF hb_completion ta_hb_consistent_convert_RA]
      obtain ttas where Runs: "mthr.if.mthr.Runs ?start_state ttas"
        and hb: "ta_hb_consistent P ?start_heap_obs (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) ttas))"
        by blast

      from Runs have: "lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) ttas)  mthr.if.ℰ ?start_state"
        by(rule mthr.if.ℰ.intros)
        
      let ?E = "lappend (llist_of ?start_heap_obs) (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) ttas))"
      fromhave E': "?E  ?ℰ" by blast

      fromhave tsa: "thread_start_actions_ok ?E" by(rule thread_start_actions_ok_init_fin)

      from start_heap_obs_not_Read
      have ws: "is_write_seen P (llist_of (lift_start_obs start_tid start_heap_obs)) ws"
        by(unfold in_set_conv_nth)(rule is_write_seenI, auto simp add: action_obs_def actions_def lift_start_obs_def lnth_LCons elim!: read_actions.cases split: nat.split_asm)

      with hb tsa
      have "ws'. P  (?E, ws')  
                  (n. n  read_actions ?E  length ?start_heap_obs  n  P,?E  ws' n ≤hb n) 
                  (n<length ?start_heap_obs. ws' n = ws n)"
        by(rule ta_hb_consistent_Read_hb)(rule jmm.ℰ_new_actions_for_fun[OF E'])
      then obtain ws' where wf_exec': "P  (?E, ws') " 
        and read_hb: "n.  n  read_actions ?E; length ?start_heap_obs  n   P,?E  ws' n ≤hb n"
        and same: "n. n<length ?start_heap_obs  ws' n = ws n" by blast

      from True have "?same ?E" unfolding E by(simp add: ltake_lappend1)
      moreover {
        fix a
        assume a: "a  read_actions ?E"
        have "if a < r then ws' a = ws a else P,?E  ws' a ≤hb a"
        proof(cases "a < length ?start_heap_obs")
          case True
          with a have False using start_heap_obs_not_Read
            by cases(auto simp add: action_obs_def actions_def lnth_lappend1 lift_start_obs_def lnth_LCons in_set_conv_nth split: nat.split_asm)
          thus ?thesis ..
        next
          case False
          with read_hb[of a] True a show ?thesis by auto
        qed }
      hence "?read ?E ws'" by blast
      moreover from True E have "?tid ?E" by(simp add: action_tid_def lnth_lappend1)
      moreover from True E have "?obs ?E" by(simp add: action_obs_def lnth_lappend1)
      moreover from True have "?actions ?E" by(simp add: actions_def enat_less_enat_plusI)
      ultimately show ?thesis using E' wf_exec' by blast
    next
      case False
      hence r: "length ?start_heap_obs  r" by simp

      show ?thesis
      proof(cases "enat r < llength E")
        case False
        then obtain "?same E" "?read E ws" "?tid E" "?obs E" "?actions E"
          by(cases "llength E")(fastforce elim!: read_actions.cases simp add: actions_def split: if_split_asm)+
        with wf_exec E  ?ℰ show ?thesis by blast
      next
        case True
        note r' = this

        let ?r = "r - length ?start_heap_obs"
        from E r r' have "enat ?r < llength E''" by(cases "llength E''")(auto)
        with τRuns obtain r_m r_n t_r ta_r 
          where E_r: "lnth E'' ?r = (t_r, ta_ro ! r_n)"
          and r_n: "r_n < length ta_ro" and r_m: "enat r_m < llength E'"
          and r_conv: "?r = (i<r_m. length snd (lnth E' i)o) + r_n"
          and E'_r_m: "lnth E' r_m = (t_r, ta_r)"
          unfolding E' by(rule mthr.if.actions_ℰE_aux)

        let ?E' = "ldropn (Suc r_m) E'"
        let ?r_m_E' = "ltake (enat r_m) E'"
        have E'_unfold: "E' = lappend (ltake (enat r_m) E') (LCons (lnth E' r_m) ?E')"
          unfolding ldropn_Suc_conv_ldropn[OF r_m] by simp
        hence "mthr.if.mthr.Runs ?start_state (lappend ?r_m_E' (LCons (lnth E' r_m) ?E'))"
          using τRuns by simp
        then obtain σ' where σ_σ': "mthr.if.mthr.Trsys ?start_state (list_of ?r_m_E') σ'"
          and τRuns': "mthr.if.mthr.Runs σ' (LCons (lnth E' r_m) ?E')"
          by(rule mthr.if.mthr.Runs_lappendE) simp
        from τRuns' obtain σ''' where red_ra: "mthr.if.redT σ' (t_r, ta_r) σ'''"
          and τRuns'': "mthr.if.mthr.Runs σ''' ?E'"
          unfolding E'_r_m by cases

        let ?vs = "mrw_values P Map.empty (map snd ?start_heap_obs)"
        from E  ?ℰ wf_exec have "ta_seq_consist P Map.empty (lmap snd (ltake (enat r) E))"
          by(rule jmm.ta_seq_consist_mrwI)(simp add: mrw)
        hence ns: "non_speculative P (λ_. {}) (lmap snd (ltake (enat r) E))"
          by(rule ta_seq_consist_into_non_speculative) simp
        also note E also note ltake_lappend2 also note E'
        also note E'_unfold also note lmap_lappend_distrib also note lmap_lappend_distrib 
        also note lconcat_lappend also note llist.map(2) also note E'_r_m also note prod.simps(2)
        also note ltake_lappend2 also note lconcat_LCons also note ltake_lappend1
        also note non_speculative_lappend also note lmap_lappend_distrib also note non_speculative_lappend
        also have "lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) (ltake (enat r_m) E')) = 
                  llist_of (concat (map (λ(t, ta). map (Pair t) tao) (list_of (ltake (enat r_m) E'))))"
          by(simp add: lconcat_llist_of[symmetric] lmap_llist_of[symmetric] llist.map_comp o_def split_def del: lmap_llist_of)
        ultimately
        have "non_speculative P (λ_. {}) (lmap snd (llist_of ?start_heap_obs))"
          and "non_speculative P (w_values P (λ_. {}) (map snd ?start_heap_obs)) 
                 (lmap snd (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) (ltake (enat r_m) E'))))"
          and ns': "non_speculative P (w_values P (w_values P (λ_. {}) (map snd ?start_heap_obs)) (map snd (concat (map (λ(t, ta). map (Pair t) tao) (list_of (ltake (enat r_m) E'))))))
               (lmap snd (ltake (enat r_n) (llist_of (map (Pair t_r) ta_ro))))"
          using r r_conv r_m r_n
          by(simp_all add: length_concat o_def split_def sum_list_sum_nth length_list_of_conv_the_enat less_min_eq1 atLeast0LessThan lnth_ltake split: if_split_asm cong: sum.cong_simp)
        hence ns: "non_speculative P (w_values P (λ_. {}) (map snd ?start_heap_obs)) 
                     (llist_of (concat (map (λ(t, ta). tao) (list_of (ltake (enat r_m) E')))))"
          unfolding lconcat_llist_of[symmetric] lmap_lconcat lmap_llist_of[symmetric] llist.map_comp o_def split_def
          by(simp)

        from ns'
        have ns': "non_speculative P (w_values P (w_values P (λ_. {}) (map snd ?start_heap_obs))  (concat (map (λ(t, ta). tao) (list_of (ltake (enat r_m) E'))))) (llist_of (take r_n ta_ro))"
          unfolding map_concat map_map by(simp add: take_map[symmetric] o_def split_def)

        let ?hb = "λta'_r  :: ('addr, 'thread_id, status × 'x, 'heap, 'addr, ('addr, 'thread_id) obs_event action) thread_action. 
             ta_hb_consistent P (?start_heap_obs @ concat (map (λ(t, ta). map (Pair t) tao) (list_of (ltake (enat r_m) E'))) @ map (Pair t_r) (take r_n ta_ro)) (llist_of (map (Pair t_r) (drop r_n ta'_ro)))"
        let ?sim = "λta'_r. (if ad al v. ta_ro ! r_n = NormalAction (ReadMem ad al v) then sim_action else (=)) (ta_ro ! r_n) (ta'_ro ! r_n)"

        from red_ra obtain ta'_r σ''''
          where red_ra': "mthr.if.redT σ' (t_r, ta'_r) σ''''"
          and eq: "take r_n ta'_ro = take r_n ta_ro"
          and hb: "?hb ta'_r"
          and r_n': "r_n < length ta'_ro"
          and sim: "?sim ta'_r"
        proof(cases)
          case (redT_normal x x' m')
          note tst = ‹thr σ' t_r = (x, no_wait_locks)
            and red = t_r  (x, shr σ') -ta_r→i (x', m')
            and aok = ‹mthr.if.actions_ok σ' t_r ta_r
            and σ''' = ‹redT_upd σ' t_r ta_r x' m' σ'''
          from if.hb_completionD[OF hb_completion σ_σ'[folded mthr.if.RedT_def] ns tst red aok ns'] r_n
          obtain ta'_r x'' m''
            where red': "t_r  (x, shr σ') -ta'_r→i (x'', m'')"
            and aok': "mthr.if.actions_ok σ' t_r ta'_r"
            and eq': "take r_n ta'_ro = take r_n ta_ro"
            and hb: "?hb ta'_r" 
            and r_n': "r_n < length ta'_ro"
            and sim: "?sim ta'_r" by blast
          from redT_updWs_total[of t_r "wset σ'" "ta'_rw"]
          obtain σ'''' where "redT_upd σ' t_r ta'_r x'' m'' σ''''" by fastforce
          with red' tst aok' have "mthr.if.redT σ' (t_r, ta'_r) σ''''" ..
          thus thesis using eq' hb r_n' sim by(rule that)
        next
          case (redT_acquire x n ln)
          hence "?hb ta_r" using set_convert_RA_not_Read[where ln=ln]
            by -(rule ta_hb_consistent_not_ReadI, fastforce simp del: set_convert_RA_not_Read dest!: in_set_dropD)
          with red_ra r_n show ?thesis by(auto intro: that)
        qed
        from hb
        have "non_speculative P (w_values P (λ_. {}) (map snd (?start_heap_obs @ concat (map (λ(t, ta). map (Pair t) tao) (list_of (ltake (enat r_m) E'))) @ map (Pair t_r) (take r_n ta_ro)))) (lmap snd (llist_of (map (Pair t_r) (drop r_n ta'_ro))))"
          by(rule ta_hb_consistent_into_non_speculative)
        with ns' eq[symmetric] have "non_speculative P (w_values P (λ_. {}) (map snd (?start_heap_obs @ concat (map (λ(t, ta). map (Pair t) tao) (list_of (ltake (enat r_m) E')))))) (llist_of (map snd (map (Pair t_r) ta'_ro)))"
          by(subst append_take_drop_id[where xs="ta'_ro" and n=r_n, symmetric])(simp add: o_def map_concat split_def lappend_llist_of_llist_of[symmetric] non_speculative_lappend del: append_take_drop_id lappend_llist_of_llist_of)
        with ns have ns'': "non_speculative P (w_values P (λ_. {}) (map snd ?start_heap_obs)) (llist_of (concat (map (λ(t, ta). tao) (list_of (ltake (enat r_m) E') @ [(t_r, ta'_r)]))))"
          unfolding lconcat_llist_of[symmetric] map_append lappend_llist_of_llist_of[symmetric] lmap_llist_of[symmetric] llist.map_comp
          by(simp add: o_def split_def non_speculative_lappend list_of_lconcat map_concat)
        from σ_σ' red_ra' have "mthr.if.RedT ?start_state (list_of ?r_m_E' @ [(t_r, ta'_r)]) σ''''"
          unfolding mthr.if.RedT_def ..
        with hb_completion
        have hb_completion': "if.hb_completion σ'''' (?start_heap_obs @ concat (map (λ(t, ta). map (Pair t) tao) (list_of (ltake (enat r_m) E') @ [(t_r, ta'_r)])))"
          using ns'' by(rule if.hb_completion_shift)
        from if.hb_completion_Runs[OF hb_completion' ta_hb_consistent_convert_RA]
        obtain ttas' where Runs': "mthr.if.mthr.Runs σ'''' ttas'"
          and hb': "ta_hb_consistent P (?start_heap_obs @ concat (map (λ(t, ta). map (Pair t) tao) (list_of (ltake (enat r_m) E') @ [(t_r, ta'_r)]))) (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) ttas'))"
          by blast

        let ?E = "lappend (llist_of ?start_heap_obs) (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) (lappend (ltake (enat r_m) E') (LCons (t_r, ta'_r) ttas'))))"

        have: "lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) (lappend (ltake (enat r_m) E') (LCons (t_r, ta'_r) ttas')))  mthr.if.ℰ ?start_state"
          by(subst (4) llist_of_list_of[symmetric])(simp, blast intro: mthr.if.ℰ.intros mthr.if.mthr.Trsys_into_Runs σ_σ' mthr.if.mthr.Runs.Step red_ra' Runs')
        hence ℰ': "?E  ?ℰ" by blast

        fromhave tsa: "thread_start_actions_ok ?E" by(rule thread_start_actions_ok_init_fin)
        also let ?E' = "lappend (llist_of (lift_start_obs start_tid start_heap_obs @ concat (map (λ(t, ta). map (Pair t) tao) (list_of (ltake (enat r_m) E'))) @ map (Pair t_r) (take r_n ta_ro))) (lappend (llist_of (map (Pair t_r) (drop r_n ta'_ro))) (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) ttas')))"
        have "?E = ?E'"
          using eq[symmetric]
          by(simp add: lmap_lappend_distrib lappend_assoc lappend_llist_of_llist_of[symmetric] lconcat_llist_of[symmetric] lmap_llist_of[symmetric] llist.map_comp o_def split_def del: lmap_llist_of)(simp add: lappend_assoc[symmetric] lmap_lappend_distrib[symmetric] map_append[symmetric] lappend_llist_of_llist_of del: map_append)
        finally have tsa': "thread_start_actions_ok ?E'" .

        from hb hb' eq[symmetric]
        have HB: "ta_hb_consistent P (?start_heap_obs @ concat (map (λ(t, ta). map (Pair t) tao) (list_of (ltake (enat r_m) E'))) @ map (Pair t_r) (take r_n ta_ro)) (lappend (llist_of (map (Pair t_r) (drop r_n ta'_ro))) (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) ttas')))"
          by -(rule ta_hb_consistent_lappendI, simp_all add: take_map[symmetric] drop_map[symmetric])
        
        define EE where "EE = llist_of (?start_heap_obs @ concat (map (λ(t, ta). map (Pair t) tao) (list_of (ltake (enat r_m) E'))) @ map (Pair t_r) (take r_n ta_ro))"

        from r r_conv have r_conv': "r = (i<r_m. length snd (lnth E' i)o) + r_n + length ?start_heap_obs" by auto
        hence len_EE: "llength EE = enat r" using r_m r_n
          by(auto simp add: EE_def length_concat sum_list_sum_nth atLeast0LessThan lnth_ltake less_min_eq1 split_def min_def length_list_of_conv_the_enat cong: sum.cong_simp)
        
        from r_conv r_m
        have r_conv3: "llength (lconcat (lmap (λx. llist_of (map (Pair (fst x)) snd xo)) (ltake (enat r_m) E'))) = enat (r - Suc (length start_heap_obs) - r_n)" 
          apply(simp add: llength_lconcat_lfinite_conv_sum lnth_ltake cong: sum.cong_simp conj_cong)
          apply(auto simp add: sum_hom[where f=enat, symmetric] zero_enat_def less_trans[where y="enat r_m"] intro: sum.cong)
          done            

        have is_ws: "is_write_seen P EE ws"
        proof(rule is_write_seenI)
          fix a ad al v
          assume a: "a  read_actions EE"
            and a_obs: "action_obs EE a = NormalAction (ReadMem ad al v)"
          from a have a_r: "a < r" by cases(simp add: len_EE actions_def)

          from r E'_r_m r_m r_n r_conv3
          have eq: "ltake (enat r) EE = ltake (enat r) E"
            unfolding E E' EE_def
            apply(subst (2) E'_unfold)
            apply(simp add: ltake_lappend2 lappend_llist_of_llist_of[symmetric] lappend_eq_lappend_conv lmap_lappend_distrib lconcat_llist_of[symmetric] o_def split_def lmap_llist_of[symmetric] del: lappend_llist_of_llist_of lmap_llist_of)
            apply(subst ltake_lappend1)
            defer
            apply(simp add: ltake_lmap[symmetric] take_map[symmetric] ltake_llist_of[symmetric] del: ltake_lmap ltake_llist_of)
            apply(auto simp add: min_def)
            done
          hence sim: "ltake (enat r) EE [≈] ltake (enat r) E" by(rule eq_into_sim_actions)
          
          from a sim have a': "a  read_actions E"
            by(rule read_actions_change_prefix)(simp add: a_r)
          from action_obs_change_prefix_eq[OF eq, of a] a_r a_obs
          have a_obs': "action_obs E a = NormalAction (ReadMem ad al v)" by simp
          
          have a_mrw: "P,E  a ↝mrw ws a" using a_r a' by(rule mrw)
          with E  ?ℰ wf_exec have ws_a_a: "ws a < a"
            by(rule jmm.mrw_before)(auto intro: a_r less_trans mrw)
          hence [simp]: "ws a < r" using a_r by simp

          from wf_exec have ws: "is_write_seen P E ws" by(rule wf_exec_is_write_seenD)
          from is_write_seenD[OF this a' a_obs']
          have "ws a  write_actions E"
            and "(ad, al)  action_loc P E (ws a)"
            and "value_written P E (ws a) (ad, al) = v"
            and "¬ P,E  a ≤hb ws a"
            and "is_volatile P al  ¬ P,E  a ≤so ws a"
            and between: "a'.  a'  write_actions E; (ad, al)  action_loc P E a'; 
                        P,E  ws a ≤hb a'  P,E  a' ≤hb a  is_volatile P al  P,E  ws a ≤so a'  P,E  a' ≤so a 
                       a' = ws a" by simp_all

          from ws a  write_actions E sim[symmetric]
          show "ws a  write_actions EE" by(rule write_actions_change_prefix) simp
          
          from action_loc_change_prefix[OF sim, of "ws a" P] (ad, al)  action_loc P E (ws a)
          show "(ad, al)  action_loc P EE (ws a)" by(simp)

          from value_written_change_prefix[OF eq, of "ws a" P] ‹value_written P E (ws a) (ad, al) = v
          show "value_written P EE (ws a) (ad, al) = v" by simp
          
           from wf_exec have tsa_E: "thread_start_actions_ok E"
              by(rule wf_exec_thread_start_actions_okD)

          from ¬ P,E  a ≤hb ws a show "¬ P,EE  a ≤hb ws a"
          proof(rule contrapos_nn)
            assume "P,EE  a ≤hb ws a"
            thus "P,E  a ≤hb ws a" using tsa_E sim
              by(rule happens_before_change_prefix)(simp_all add: a_r)
          qed

          { assume "is_volatile P al"
            hence "¬ P,E  a ≤so ws a" by fact
            thus "¬ P,EE  a ≤so ws a"
              by(rule contrapos_nn)(rule sync_order_change_prefix[OF _ sim], simp_all add: a_r) }
          
          fix a'
          assume "a'  write_actions EE" "(ad, al)  action_loc P EE a'"
          moreover
          hence [simp]: "a' < r" by cases(simp add: actions_def len_EE)
          ultimately have a': "a'  write_actions E" "(ad, al)  action_loc P E a'"
            using sim action_loc_change_prefix[OF sim, of a' P]
            by(auto intro: write_actions_change_prefix)
          { assume "P,EE  ws a ≤hb a'" "P,EE  a' ≤hb a"
            hence "P,E  ws a ≤hb a'" "P,E  a' ≤hb a"
              using tsa_E sim a_r by(auto elim!: happens_before_change_prefix)
            with between[OF a'] show "a' = ws a" by simp }
          { assume "is_volatile P al " "P,EE  ws a ≤so a'" "P,EE  a' ≤so a"
            with sim a_r between[OF a'] show "a' = ws a"
              by(fastforce elim: sync_order_change_prefix intro!: disjI2 del: disjCI) }
        qed

        with HB tsa'
        have "ws'. P  (?E', ws')  
                    (n. n  read_actions ?E'  length (?start_heap_obs @ concat (map (λ(t, ta). map (Pair t) tao) (list_of (ltake (enat r_m) E'))) @ map (Pair t_r) (take r_n ta_ro))  n  P,?E'  ws' n ≤hb n) 
                    (n<length (lift_start_obs start_tid start_heap_obs @ concat (map (λ(t, ta). map (Pair t) tao) (list_of (ltake (enat r_m) E'))) @ map (Pair t_r) (take r_n ta_ro)). ws' n = ws n)"
          unfolding EE_def
          by(rule ta_hb_consistent_Read_hb)(rule jmm.ℰ_new_actions_for_fun[OF ℰ'[unfolded ?E = ?E']])
        also have r_conv'': "length (?start_heap_obs @ concat (map (λ(t, ta). map (Pair t) tao) (list_of (ltake (enat r_m) E'))) @ map (Pair t_r) (take r_n ta_ro)) = r"
          using r_n r_m unfolding r_conv'
          by(auto simp add: length_concat sum_list_sum_nth atLeast0LessThan lnth_ltake split_def o_def less_min_eq1 min_def length_list_of_conv_the_enat cong: sum.cong_simp)
        finally obtain ws' where wf_exec': "P  (?E', ws') " 
          and read_hb: "n.  n  read_actions ?E'; r  n   P,?E'  ws' n ≤hb n"
          and read_same: "n. n < r  ws' n = ws n" by blast

        have "?same ?E'"
          apply(subst ltake_lappend1, simp add: r_conv''[symmetric] length_list_of_conv_the_enat)
          unfolding E E' lappend_llist_of_llist_of[symmetric]
          apply(subst (1 2) ltake_lappend2, simp add: r[simplified])
          apply(subst lappend_eq_lappend_conv, simp)
          apply safe
          apply(subst E'_unfold)
          unfolding lmap_lappend_distrib 
          apply(subst lconcat_lappend, simp)
          apply(subst lconcat_llist_of[symmetric])
          apply(subst (3) lmap_llist_of[symmetric])
          apply(subst (3) lmap_llist_of[symmetric])
          apply(subst llist.map_comp)
          apply(simp only: split_def o_def)
          apply(subst llist_of_list_of, simp)
          apply(subst (1 2) ltake_lappend2, simp add: r_conv3)
          apply(subst lappend_eq_lappend_conv, simp)
          apply safe
          unfolding llist.map(2) lconcat_LCons E'_r_m snd_conv fst_conv take_map
          apply(subst ltake_lappend1)
           defer
           apply(subst append_take_drop_id[where xs="ta_ro" and n=r_n, symmetric])
           unfolding map_append lappend_llist_of_llist_of[symmetric]
           apply(subst ltake_lappend1)
            using r_n
            apply(simp add: min_def r_conv3)
           apply(rule refl)
          apply(simp add: r_conv3)
          using r_n by arith

        moreover {
          fix a
          assume "a  read_actions ?E'"
          with read_hb[of a] read_same[of a]
          have "if a < r then ws' a = ws a else P,?E'  ws' a ≤hb a" by simp }
        hence "?read ?E' ws'" by blast
        moreover from r_m r_n r_n'
        have E'_r: "lnth ?E' r = (t_r, ta'_ro ! r_n)" unfolding r_conv'
          by(auto simp add: lnth_lappend nth_append length_concat sum_list_sum_nth atLeast0LessThan split_beta lnth_ltake less_min_eq1 length_list_of_conv_the_enat cong: sum.cong_simp)
        from E_r r have E_r: "lnth E r = (t_r, ta_ro ! r_n)"
          unfolding E by(simp add: lnth_lappend)
        have "r  read_actions E  (ad al v. ta_ro ! r_n = NormalAction (ReadMem ad al v))" using True
          by(auto elim!: read_actions.cases simp add: action_obs_def E_r actions_def intro!: read_actions.intros)
        with sim E'_r E_r have "?tid ?E'" "?obs ?E'"
          by(auto simp add: action_tid_def action_obs_def)
        moreover have "?actions ?E'" using r_n r_m r_n' unfolding r_conv'
          by(cases "llength ?E'")(auto simp add: actions_def less_min_eq2 length_concat sum_list_sum_nth atLeast0LessThan split_beta lnth_ltake less_min_eq1 length_list_of_conv_the_enat enat_plus_eq_enat_conv cong: sum.cong_simp)
        ultimately show ?thesis using wf_exec' ℰ'
          unfolding ?E = ?E' by blast
      qed
    qed
  qed
qed

end

lemma w_value_mrw_value_conf:
  assumes "set_option (vs' adal)  vs adal × UNIV"
  shows "set_option (mrw_value P vs' ob adal)  w_value P vs ob adal × UNIV"
using assms by(cases adal)(cases ob rule: w_value_cases, auto)

lemma w_values_mrw_values_conf:
  assumes "set_option (vs' adal)  vs adal × UNIV"
  shows "set_option (mrw_values P vs' obs adal)  w_values P vs obs adal × UNIV"
using assms
by(induct obs arbitrary: vs' vs)(auto del: subsetI intro: w_value_mrw_value_conf)

lemma w_value_mrw_value_dom_eq_preserve:
  assumes "dom vs' = {adal. vs adal  {}}"
  shows "dom (mrw_value P vs' ob) = {adal. w_value P vs ob adal  {}}"
using assms
apply(cases ob rule: w_value_cases)
apply(simp_all add: dom_def split_beta del: not_None_eq)
apply(blast elim: equalityE dest: subsetD)+
done

lemma w_values_mrw_values_dom_eq_preserve:
  assumes "dom vs' = {adal. vs adal  {}}"
  shows "dom (mrw_values P vs' obs) = {adal. w_values P vs obs adal  {}}"
using assms
by(induct obs arbitrary: vs vs')(auto del: equalityI intro: w_value_mrw_value_dom_eq_preserve)

context jmm_multithreaded begin

definition non_speculative_read :: 
  "nat  ('l, 'thread_id, 'x, 'm, 'w) state  ('addr × addr_loc  'addr val set)  bool"
where
  "non_speculative_read n s vs 
   (ttas s' t x ta x' m' i ad al v v'.
       s -▹ttas→* s'  non_speculative P vs (llist_of (concat (map (λ(t, ta). tao) ttas))) 
       thr s' t = (x, no_wait_locks)  t  (x, shr s') -ta (x', m')  actions_ok s' t ta  
       i < length tao  
       non_speculative P (w_values P vs (concat (map (λ(t, ta). tao) ttas))) (llist_of (take i tao)) 
       tao ! i = NormalAction (ReadMem ad al v)  
       v'  w_values P vs (concat (map (λ(t, ta). tao) ttas) @ take i tao) (ad, al) 
       (ta' x'' m''. t  (x, shr s') -ta' (x'', m'')  actions_ok s' t ta' 
                      i < length ta'o  take i ta'o = take i tao  ta'o ! i = NormalAction (ReadMem ad al v') 
                      length ta'o  max n (length tao)))" 

lemma non_speculative_readI [intro?]:
  "(ttas s' t x ta x' m' i ad al v v'. 
     s -▹ttas→* s'; non_speculative P vs (llist_of (concat (map (λ(t, ta). tao) ttas)));
     thr s' t = (x, no_wait_locks); t  (x, shr s') -ta (x', m'); actions_ok s' t ta;
     i < length tao; non_speculative P (w_values P vs (concat (map (λ(t, ta). tao) ttas))) (llist_of (take i tao));
     tao ! i = NormalAction (ReadMem ad al v);
     v'  w_values P vs (concat (map (λ(t, ta). tao) ttas) @ take i tao) (ad, al) 
     ta' x'' m''. t  (x, shr s') -ta' (x'', m'')  actions_ok s' t ta' 
                      i < length ta'o  take i ta'o = take i tao  ta'o ! i = NormalAction (ReadMem ad al v') 
                      length ta'o  max n (length tao))
   non_speculative_read n s vs"
unfolding non_speculative_read_def by blast

lemma non_speculative_readD:
  " non_speculative_read n s vs; s -▹ttas→* s'; non_speculative P vs (llist_of (concat (map (λ(t, ta). tao) ttas)));
     thr s' t = (x, no_wait_locks); t  (x, shr s') -ta (x', m'); actions_ok s' t ta;
     i < length tao; non_speculative P (w_values P vs (concat (map (λ(t, ta). tao) ttas))) (llist_of (take i tao)); 
     tao ! i = NormalAction (ReadMem ad al v);
     v'  w_values P vs (concat (map (λ(t, ta). tao) ttas) @ take i tao) (ad, al) 
   ta' x'' m''. t  (x, shr s') -ta' (x'', m'')  actions_ok s' t ta' 
                      i < length ta'o  take i ta'o = take i tao  ta'o ! i = NormalAction (ReadMem ad al v') 
                      length ta'o  max n (length tao)"
unfolding non_speculative_read_def by blast

end

subsection @{term "non_speculative"} generalises @{term "cut_and_update"} and @{term "ta_hb_consistent"}

context known_addrs_typing begin

lemma read_non_speculative_new_actions_for:
  fixes status f C M params E
  defines "E  lift_start_obs start_tid start_heap_obs"
  and "vs  w_values P (λ_. {}) (map snd E)"
  and "s  init_fin_lift_state status (start_state f P C M params)"
  assumes wf: "wf_syscls P"
  and RedT: "mthr.if.RedT s ttas s'"
  and redT: "mthr.if.redT s' (t, ta') s''"
  and read: "NormalAction (ReadMem ad al v)  set ta'o"
  and ns: "non_speculative P (λ_. {}) (llist_of (map snd E @ concat (map (λ(t, ta). tao) ttas)))"
  and ka: "known_addrs start_tid (f (fst (method P C M)) M (fst (snd (method P C M))) (fst (snd (snd (method P C M)))) (the (snd (snd (snd (method P C M))))) params)  allocated start_heap"
  and wt: "ts_ok (init_fin_lift wfx) (thr s) (shr s)"
  and type_adal: "P,shr s'  ad@al : T"
  shows "w. w  new_actions_for P (llist_of (E @ concat (map (λ(t, ta). map (Pair t) tao) ttas))) (ad, al)"
  (is "w. ?new_w w")
using RedT redT read ns[unfolded E_def] ka unfolding s_def
proof(cases rule: read_ex_NewHeapElem)
  case (start CTn)
  then obtain n where n: "start_heap_obs ! n = NewHeapElem ad CTn"
    and len: "n < length start_heap_obs"
    unfolding in_set_conv_nth by blast
  from ns have "non_speculative P (w_values P (λ_. {}) (map snd E)) (llist_of (concat (map (λ(t, ta). tao) ttas)))"
    unfolding lappend_llist_of_llist_of[symmetric]
    by(simp add: non_speculative_lappend del: lappend_llist_of_llist_of)
  with RedT wt have hext: "start_heap  shr s'"
    unfolding s_def E_def using start_state_vs_conf[OF wf]
    by(auto dest!: init_fin_RedT_hext_incr simp add: start_state_def split_beta init_fin_lift_state_conv_simps)
  
  from start have "typeof_addr start_heap ad = CTn"
    by(auto dest: NewHeapElem_start_heap_obsD[OF wf])
  with hext have "typeof_addr (shr s') ad = CTn" by(rule typeof_addr_hext_mono)
  with type_adal have "(ad, al)  action_loc_aux P (NormalAction (NewHeapElem ad CTn))" using n len 
    by cases (auto simp add: action_obs_def lnth_lappend1 lift_start_obs_def)
  with n len have "?new_w (Suc n)"
    by(simp add: new_actions_for_def actions_def E_def action_obs_def lift_start_obs_def nth_append)
  thus ?thesis ..
next
  case (Red ttas' s'' t' ta' s''' ttas'' CTn)
  note ttas = ttas = ttas' @ (t', ta') # ttas''
  
  from ‹NormalAction (NewHeapElem ad CTn)  set ta'o
  obtain obs obs' where obs: "ta'o = obs @ NormalAction (NewHeapElem ad CTn) # obs'"
    by(auto dest: split_list)
  
  let ?n = "length (lift_start_obs start_tid start_heap_obs)"
  let ?wa = "?n + length (concat (map (λ(t, ta). tao) ttas')) + length obs"
  
  have "?wa = ?n + length (concat (map (λ(t, ta). map (Pair t) tao) ttas')) + length obs"
    by(simp add: length_concat o_def split_def)
  also have " < length (E @ concat (map (λ(t, ta). map (Pair t) tao) ttas))"
    using obs ttas by(simp add: E_def)
  also
  from ttas obs
  have "(E @ concat (map (λ(t, ta). map (Pair t) tao) ttas)) ! ?wa = (t', NormalAction (NewHeapElem ad CTn))"
    by(auto simp add: E_def lift_start_obs_def nth_append o_def split_def length_concat)
  moreover
  from ‹mthr.if.redT s'' (t', ta') s''' ‹NormalAction (NewHeapElem ad CTn)  set ta'o
  obtain x_wa x_wa' where ts''t': "thr s'' t' = (x_wa, no_wait_locks)"
    and red_wa: "mthr.init_fin t' (x_wa, shr s'') ta' (x_wa', shr s''')"
    by(cases) fastforce+

  from start_state_vs_conf[OF wf]
  have vs: "vs_conf P (shr s) vs" unfolding vs_def E_def s_def
    by(simp add: init_fin_lift_state_conv_simps start_state_def split_def)
  
  from ns
  have ns: "non_speculative P vs (llist_of (concat (map (λ(t, ta). tao) ttas')))"
    and ns': "non_speculative P (w_values P vs (concat (map (λ(t, ta). tao) ttas'))) (llist_of ta'o)"
    and ns'': "non_speculative P (w_values P (w_values P vs (concat (map (λ(t, ta). tao) ttas'))) ta'o) (llist_of (concat (map (λ(t, ta). tao) ttas'')))"
    unfolding ttas vs_def
    by(simp_all add: lappend_llist_of_llist_of[symmetric] non_speculative_lappend del: lappend_llist_of_llist_of)
  from ‹mthr.if.RedT (init_fin_lift_state status (start_state f P C M params)) ttas' s'' wt ns
  have ts_ok'': "ts_ok (init_fin_lift wfx) (thr s'') (shr s'')" using vs unfolding vs_def s_def
    by(rule if_RedT_non_speculative_invar)
  with ts''t' have wfxt': "wfx t' (snd x_wa) (shr s'')" by(cases x_wa)(auto dest: ts_okD)

  from ‹mthr.if.RedT (init_fin_lift_state status (start_state f P C M params)) ttas' s'' wt ns
  have vs'': "vs_conf P (shr s'') (w_values P (w_values P (λ_. {}) (map snd E)) (concat (map (λ(t, ta). tao) ttas')))"
    unfolding s_def E_def vs_def
    by(rule if_RedT_non_speculative_invar)(simp add: start_state_def split_beta init_fin_lift_state_conv_simps start_state_vs_conf[OF wf])
  from if_redT_non_speculative_vs_conf[OF ‹mthr.if.redT s'' (t', ta') s''' ts_ok'' _ vs'', of "length ta'o"] ns'
  have vs''': "vs_conf P (shr s''') (w_values P (w_values P vs (concat (map (λ(t, ta). tao) ttas'))) ta'o)"
    by(simp add: vs_def)

  from ‹mthr.if.redT s'' (t', ta') s''' ts_ok'' ns' vs''
  have "ts_ok (init_fin_lift wfx) (thr s''') (shr s''')" 
    unfolding vs_def by(rule if_redT_non_speculative_invar)
  with ‹mthr.if.RedT s''' ttas'' s'
  have hext: "shr s'''  shr s'" using ns'' vs'''
    by(rule init_fin_RedT_hext_incr)
  
  from red_wa have "typeof_addr (shr s''') ad = CTn"
    using wfxt' ‹NormalAction (NewHeapElem ad CTn)  set ta'o by cases(auto dest: red_NewHeapElemD)
  with hext have "typeof_addr (shr s') ad = CTn" by(rule typeof_addr_hext_mono)
  with type_adal have "(ad, al)  action_loc_aux P (NormalAction (NewHeapElem ad CTn))" by cases auto
  ultimately have "?new_w ?wa"
    by(simp add: new_actions_for_def actions_def action_obs_def)
  thus ?thesis ..
qed

lemma non_speculative_read_into_cut_and_update:
  fixes status f C M params E
  defines "E  lift_start_obs start_tid start_heap_obs"
  and "vs  w_values P (λ_. {}) (map snd E)"
  and "s  init_fin_lift_state status (start_state f P C M params)"
  and "vs'  mrw_values P Map.empty (map snd E)"
  assumes wf: "wf_syscls P"
  and nsr: "if.non_speculative_read n s vs"
  and wt: "ts_ok (init_fin_lift wfx) (thr s) (shr s)"
  and ka: "known_addrs start_tid (f (fst (method P C M)) M (fst (snd (method P C M))) (fst (snd (snd (method P C M)))) (the (snd (snd (snd (method P C M))))) params)  allocated start_heap"
  shows "if.cut_and_update s vs'"
proof(rule if.cut_and_updateI)
  fix ttas s' t x ta x' m'
  assume Red: "mthr.if.RedT s ttas s'"
    and sc: "ta_seq_consist P vs' (llist_of (concat (map (λ(t, ta). tao) ttas)))"
    and tst: "thr s' t = (x, no_wait_locks)"
    and red: "t  (x, shr s') -ta→i (x', m')"
    and aok: "mthr.if.actions_ok s' t ta"
  let ?vs = "w_values P vs (concat (map (λ(t, ta). tao) ttas))"
  let ?vs' = "mrw_values P vs' (concat (map (λ(t, ta). tao) ttas))"

  from start_state_vs_conf[OF wf]
  have vs: "vs_conf P (shr s) vs" unfolding vs_def E_def s_def
    by(simp add: init_fin_lift_state_conv_simps start_state_def split_def)

  from sc have ns: "non_speculative P vs (llist_of (concat (map (λ(t, ta). tao) ttas)))"
    by(rule ta_seq_consist_into_non_speculative)(auto simp add: vs'_def vs_def del: subsetI intro: w_values_mrw_values_conf)

  from ns have ns': "non_speculative P (λ_. {}) (llist_of (map snd (lift_start_obs start_tid start_heap_obs) @ concat (map (λ(t, ta). tao) ttas)))"
    unfolding lappend_llist_of_llist_of[symmetric] vs_def
    by(simp add: non_speculative_lappend E_def non_speculative_start_heap_obs del: lappend_llist_of_llist_of)

  have vs_vs'': "adal. set_option (?vs' adal)  ?vs adal × UNIV"
    by(rule w_values_mrw_values_conf)(auto simp add: vs'_def vs_def del: subsetI intro: w_values_mrw_values_conf)
  from Red wt ns vs
  have wt': "ts_ok (init_fin_lift wfx) (thr s') (shr s')"
    by(rule if_RedT_non_speculative_invar)
  hence wtt: "init_fin_lift wfx t x (shr s')" using tst by(rule ts_okD)

  { fix i
    have "ta' x'' m''. t  (x, shr s') -ta'→i (x'', m'')  mthr.if.actions_ok s' t ta' 
                        length ta'o  max n (length tao) 
                        ta_seq_consist P ?vs' (llist_of (take i ta'o)) 
                        eq_upto_seq_inconsist P (take i tao) (take i ta'o) ?vs' 
                        (ta_seq_consist P ?vs' (llist_of (take i tao))  ta' = ta)"
    proof(induct i)
      case 0 
      show ?case using red aok
        by(auto simp del: split_paired_Ex simp add: eq_upto_seq_inconsist_simps)
    next
      case (Suc i)
      then obtain ta' x'' m''
        where red': "t  (x, shr s') -ta'→i (x'', m'')"
        and aok': "mthr.if.actions_ok s' t ta'"
        and len: "length ta'o  max n (length tao)"
        and sc': "ta_seq_consist P ?vs' (llist_of (take i ta'o))"
        and eusi: "eq_upto_seq_inconsist P (take i tao) (take i ta'o) ?vs'" 
        and ta'_ta: "ta_seq_consist P ?vs' (llist_of (take i tao))  ta' = ta"
        by blast
      let ?vs'' = "mrw_values P ?vs' (take i ta'o)"
      show ?case
      proof(cases "i < length ta'o  ¬ ta_seq_consist P ?vs' (llist_of (take (Suc i) ta'o))  ¬ ta_seq_consist P ?vs' (llist_of (take (Suc i) tao))")
        case True
        hence i: "i < length ta'o" and "¬ ta_seq_consist P ?vs'' (LCons (ta'o ! i) LNil)" using sc'
          by(auto simp add: take_Suc_conv_app_nth lappend_llist_of_llist_of[symmetric] ta_seq_consist_lappend simp del: lappend_llist_of_llist_of)
        then obtain ad al v where ta'_i: "ta'o ! i = NormalAction (ReadMem ad al v)"
          by(auto split: action.split_asm obs_event.split_asm)
        from ta'_i True have read: "NormalAction (ReadMem ad al v)  set ta'o" by(auto simp add: in_set_conv_nth)
        with red' have "ad  known_addrs_if t x" by(rule if_red_read_knows_addr)
        hence "ad  if.known_addrs_state s'" using tst by(rule if.known_addrs_stateI)
        moreover from init_fin_red_read_typeable[OF red' wtt read]
        obtain T where type_adal: "P,shr s'  ad@al : T" ..

        from redT_updWs_total[of t "wset s'" "ta'w"] red' tst aok'
        obtain s'' where redT': "mthr.if.redT s' (t, ta') s''" by(auto dest!: mthr.if.redT.redT_normal)
        with wf Red
        have "w. w  new_actions_for P (llist_of (E @ concat (map (λ(t, ta). map (Pair t) tao) ttas))) (ad, al)"
          (is "w. ?new_w w")
          using read ns' ka wt type_adal unfolding s_def E_def by(rule read_non_speculative_new_actions_for)
        then obtain w where w: "?new_w w" ..
        have "(ad, al)  dom ?vs'"
        proof(cases "w < length E")
          case True
          with w have "(ad, al)  dom vs'" unfolding vs'_def new_actions_for_def
            by(clarsimp)(erule mrw_values_new_actionD[rotated 1], auto simp del: split_paired_Ex simp add: set_conv_nth action_obs_def nth_append intro!: exI[where x=w])
          also have "dom vs'  dom ?vs'" by(rule mrw_values_dom_mono)
          finally show ?thesis .
        next
          case False
          with w show ?thesis unfolding new_actions_for_def
            apply(clarsimp)
            apply(erule mrw_values_new_actionD[rotated 1])
            apply(simp_all add: set_conv_nth action_obs_def nth_append actions_def)
            apply(rule exI[where x="w - length E"])
            apply(subst nth_map[where f=snd, symmetric])
            apply(simp_all add: length_concat o_def split_def map_concat)
            done
        qed
        hence "(ad, al)  dom (mrw_values P ?vs' (take i ta'o))"
          by(rule subsetD[OF mrw_values_dom_mono])
        then obtain v' b where v': "mrw_values P ?vs' (take i ta'o) (ad, al) = (v', b)" by auto
        moreover from vs_vs''[of "(ad, al)"]
        have "set_option (mrw_values P ?vs' (take i ta'o) (ad, al))  w_values P ?vs (take i ta'o) (ad, al) × UNIV"
          by(rule w_values_mrw_values_conf)
        ultimately have "v'  w_values P ?vs (take i ta'o) (ad, al)" by simp
        moreover from sc'
        have "non_speculative P (w_values P vs (concat (map (λ(t, ta). tao) ttas))) (llist_of (take i ta'o))"
          by(blast intro: ta_seq_consist_into_non_speculative vs_vs'' del: subsetI)
        ultimately obtain ta'' x'' m''
          where red'': "t  (x, shr s') -ta''→i (x'', m'')"
          and aok'': "mthr.if.actions_ok s' t ta''"
          and i': "i < length ta''o"
          and eq: "take i ta''o = take i ta'o"
          and ta''_i: "ta''o ! i = NormalAction (ReadMem ad al v')"
          and len': "length ta''o  max n (length ta'o)"
          using if.non_speculative_readD[OF nsr Red ns tst red' aok' i _ ta'_i, of v'] by auto
        from len' len have "length ta''o  max n (length tao)" by simp
        moreover have "ta_seq_consist P ?vs' (llist_of (take (Suc i) ta''o))"
          using eq sc' i' ta''_i v'
          by(simp add: take_Suc_conv_app_nth lappend_llist_of_llist_of[symmetric] ta_seq_consist_lappend del: lappend_llist_of_llist_of)
        moreover
        have eusi': "eq_upto_seq_inconsist P (take (Suc i) tao) (take (Suc i) ta''o) ?vs'"
        proof(cases "i < length tao")
          case True
          with i' i len eq eusi ta'_i ta''_i v' show ?thesis
            by(auto simp add: take_Suc_conv_app_nth ta'_ta eq_upto_seq_inconsist_simps intro: eq_upto_seq_inconsist_appendI)
        next
          case False
          with i ta'_ta have "¬ ta_seq_consist P ?vs' (llist_of (take i tao))" by auto
          then show ?thesis using False i' eq eusi
            by(simp add: take_Suc_conv_app_nth eq_upto_seq_inconsist_append2)
        qed
        moreover {
          assume "ta_seq_consist P ?vs' (llist_of (take (Suc i) tao))"
          with True have "ta'' = ta" by simp }
        ultimately show ?thesis using red'' aok'' True by blast
      next
        case False
        hence "ta_seq_consist P ?vs' (llist_of (take (Suc i) tao))  
               length ta'o  i  
               ta_seq_consist P ?vs' (llist_of (take (Suc i) ta'o))" 
          (is "?case1  ?case2  ?case3") by auto
        thus ?thesis
        proof(elim disjCE)
          assume "?case1"
          moreover
          hence "eq_upto_seq_inconsist P (take (Suc i) tao) (take (Suc i) tao) ?vs'"
            by(rule ta_seq_consist_imp_eq_upto_seq_inconsist_refl)
          ultimately show ?thesis using red aok by fastforce
        next
          assume "?case2" and "¬ ?case1"
          have "eq_upto_seq_inconsist P (take (Suc i) tao) (take (Suc i) ta'o) ?vs'"
          proof(cases "i < length tao")
            case True
            from ?case2 ¬ ?case1 have "¬ ta_seq_consist P ?vs' (llist_of (take i tao))" by(auto simp add: ta'_ta)
            hence "eq_upto_seq_inconsist P (take i tao @ [tao ! i]) (take i ta'o @ []) ?vs'"
              by(blast intro: eq_upto_seq_inconsist_appendI[OF eusi])
            thus ?thesis using True ?case2 by(simp add: take_Suc_conv_app_nth)
          next
            case False with eusi ?case2 show ?thesis by simp
          qed
          with red' aok' len sc' eusi ?case2 ¬ ?case1show ?thesis
            by (fastforce simp add: take_all simp del: split_paired_Ex)
        next
          assume "?case3" and "¬ ?case1" and "¬ ?case2"
          with len eusi ta'_ta
          have "eq_upto_seq_inconsist P (take (Suc i) tao) (take (Suc i) ta'o) ?vs'"
            by(cases "i < length tao")(auto simp add: take_Suc_conv_app_nth lappend_llist_of_llist_of[symmetric] ta_seq_consist_lappend intro: eq_upto_seq_inconsist_appendI eq_upto_seq_inconsist_append2 cong: action.case_cong obs_event.case_cong)
          with red' aok' ?case3 len ¬ ?case1 show ?thesis by blast
        qed
      qed
    qed }
  from this[of "max n (length tao)"]
  show "ta' x'' m''. t  (x, shr s') -ta'→i (x'', m'')  mthr.if.actions_ok s' t ta'  ta_seq_consist P ?vs' (llist_of ta'o)  eq_upto_seq_inconsist P tao ta'o ?vs'"
    by(auto simp del: split_paired_Ex cong: conj_cong)
qed

lemma non_speculative_read_into_hb_completion:
  fixes status f C M params E
  defines "E  lift_start_obs start_tid start_heap_obs"
  and "vs  w_values P (λ_. {}) (map snd E)"
  and "s  init_fin_lift_state status (start_state f P C M params)"
  assumes wf: "wf_syscls P"
  and nsr: "if.non_speculative_read n s vs"
  and wt: "ts_ok (init_fin_lift wfx) (thr s) (shr s)"
  and ka: "known_addrs start_tid (f (fst (method P C M)) M (fst (snd (method P C M))) (fst (snd (snd (method P C M)))) (the (snd (snd (snd (method P C M))))) params)  allocated start_heap"
  shows "if.hb_completion s E"
proof
  fix ttas s' t x ta x' m' i
  assume Red: "mthr.if.RedT s ttas s'"
    and ns: "non_speculative P (w_values P (λ_. {}) (map snd E)) (llist_of (concat (map (λ(t, ta). tao) ttas)))"
    and tst: "thr s' t = (x, no_wait_locks)"
    and red: "t  (x, shr s') -ta→i (x', m')"
    and aok: "mthr.if.actions_ok s' t ta"
    and nsi: "non_speculative P (w_values P (w_values P (λ_. {}) (map snd E)) (concat (map (λ(t, ta). tao) ttas))) (llist_of (take i tao))"

  let ?E = "E @ concat (map (λ(t, ta). map (Pair t) tao) ttas) @ map (Pair t) (take i tao)"
  let ?vs = "w_values P vs (concat (map (λ(t, ta). tao) ttas))"

  from ns have ns': "non_speculative P (λ_. {}) (llist_of (map snd (lift_start_obs start_tid start_heap_obs) @ concat (map (λ(t, ta). tao) ttas)))"
    unfolding lappend_llist_of_llist_of[symmetric]
    by(simp add: non_speculative_lappend E_def non_speculative_start_heap_obs del: lappend_llist_of_llist_of)

  from start_state_vs_conf[OF wf]
  have vs: "vs_conf P (shr s) vs" unfolding vs_def E_def s_def
    by(simp add: init_fin_lift_state_conv_simps start_state_def split_def)

  from Red wt ns vs
  have wt': "ts_ok (init_fin_lift wfx) (thr s') (shr s')"
    unfolding vs_def by(rule if_RedT_non_speculative_invar)
  hence wtt: "init_fin_lift wfx t x (shr s')" using tst by(rule ts_okD)

  { fix j
    have "ta' x'' m''. t  (x, shr s') -ta'→i (x'', m'')  mthr.if.actions_ok s' t ta'  length ta'o  max n (length tao) 
                        take i ta'o = take i tao  
                        ta_hb_consistent P ?E (llist_of (map (Pair t) (take j (drop i ta'o)))) 
                        (i < length tao  i < length ta'o) 
                        (if ad al v. tao ! i = NormalAction (ReadMem ad al v) then sim_action else (=)) (tao ! i) (ta'o ! i)"
    proof(induct j)
      case 0 from red aok show ?case by(fastforce simp del: split_paired_Ex)
    next
      case (Suc j)
      then obtain ta' x'' m''
        where red': "t  (x, shr s') -ta'→i (x'', m'')"
        and aok': "mthr.if.actions_ok s' t ta'"
        and len: "length ta'o  max n (length tao)"
        and eq: "take i ta'o = take i tao"
        and hb: "ta_hb_consistent P ?E (llist_of (map (Pair t) (take j (drop i ta'o))))"
        and len_i: "i < length tao  i < length ta'o"
        and sim_i: "(if ad al v. tao ! i = NormalAction (ReadMem ad al v) then sim_action else (=)) (tao ! i) (ta'o ! i)"
        by blast
      show ?case
      proof(cases "i + j < length ta'o")
        case False
        with red' aok' len eq hb len_i sim_i show ?thesis by(fastforce simp del: split_paired_Ex)
      next
        case True
        note j = this
        show ?thesis
        proof(cases "ad al v. ta'o ! (i + j) = NormalAction (ReadMem ad al v)")
          case True
          then obtain ad al v where ta'_j: "ta'o ! (i + j) = NormalAction (ReadMem ad al v)" by blast
          hence read: "NormalAction (ReadMem ad al v)  set ta'o" using j by(auto simp add: in_set_conv_nth)
          with red' have "ad  known_addrs_if t x" by(rule if_red_read_knows_addr)
          hence "ad  if.known_addrs_state s'" using tst by(rule if.known_addrs_stateI)
          from init_fin_red_read_typeable[OF red' wtt read] obtain T 
            where type_adal: "P,shr s'  ad@al : T" ..

          from redT_updWs_total[of t "wset s'" "ta'w"] red' tst aok'
          obtain s'' where redT': "mthr.if.redT s' (t, ta') s''" by(auto dest!: mthr.if.redT.redT_normal)
          with wf Red
          have "w. w  new_actions_for P (llist_of (E @ concat (map (λ(t, ta). map (Pair t) tao) ttas))) (ad, al)"
            (is "w. ?new_w w")
            using read ns' ka wt type_adal unfolding s_def E_def
            by(rule read_non_speculative_new_actions_for)
          then obtain w where w: "?new_w w" ..

          define E'' where "E'' = ?E @ map (Pair t) (take (Suc j) (drop i ta'o))"

          from Red redT' have "mthr.if.RedT s (ttas @ [(t, ta')]) s''" unfolding mthr.if.RedT_def ..
          hence tsa: "thread_start_actions_ok (llist_of (lift_start_obs start_tid start_heap_obs @ concat (map (λ(t, ta). map (Pair t) tao) (ttas @ [(t, ta')]))))"
            unfolding s_def by(rule thread_start_actions_ok_init_fin_RedT)
          hence "thread_start_actions_ok (llist_of E'')" unfolding E_def[symmetric] E''_def
            by(rule thread_start_actions_ok_prefix)(rule lprefix_llist_ofI, simp, metis append_take_drop_id eq map_append)
          moreover from w have "w  actions (llist_of E'')"
            unfolding E''_def by(auto simp add: new_actions_for_def actions_def)
          moreover have "length ?E + j  actions (llist_of E'')" using j by(auto simp add: E''_def actions_def)
          moreover from w have "is_new_action (action_obs (llist_of E'') w)"
            by(auto simp add: new_actions_for_def action_obs_def actions_def nth_append E''_def)
          moreover have "¬ is_new_action (action_obs (llist_of E'') (length ?E + j))"
            using j ta'_j by(auto simp add: action_obs_def nth_append min_def E''_def)(subst (asm) nth_map, simp_all)
          ultimately have hb_w: "P,llist_of E''  w ≤hb length ?E + j"
            by(rule happens_before_new_not_new)
          
          define writes where
            "writes = {w. P,llist_of E''  w ≤hb length ?E + j  w  write_actions (llist_of E'')  
                 (ad, al)  action_loc P (llist_of E'') w}"

          define w' where "w' = Max_torder (action_order (llist_of E'')) writes"

          have writes_actions: "writes  actions (llist_of E'')" unfolding writes_def actions_def
            by(auto dest!: happens_before_into_action_order elim!: action_orderE simp add: actions_def)
          also have "finite " by(simp add: actions_def)
          finally (finite_subset) have "finite writes" .
          moreover from hb_w w have w_writes: "w  writes"
            by(auto 4 3 simp add: writes_def new_actions_for_def action_obs_def actions_def nth_append E''_def intro!: write_actions.intros elim!: is_new_action.cases)
          hence "writes  {}" by auto

          with torder_action_order ‹finite writes 
          have w'_writes: "w'  writes" using writes_actions unfolding w'_def by(rule Max_torder_in_set)
          moreover
          { fix w''
            assume "w''  writes"
            with torder_action_order ‹finite writes
            have "llist_of E''  w'' ≤a w'" using writes_actions unfolding w'_def by(rule Max_torder_above) }
          note w'_maximal = this

          define v' where "v' = value_written P (llist_of E'') w' (ad, al)"

          from nsi ta_hb_consistent_into_non_speculative[OF hb]
          have nsi': "non_speculative P (w_values P vs (concat (map (λ(t, ta). tao) ttas))) (llist_of (take (i + j) ta'o))"
            unfolding take_add lappend_llist_of_llist_of[symmetric] non_speculative_lappend vs_def eq
            by(simp add: non_speculative_lappend o_def map_concat split_def del: lappend_llist_of_llist_of)
            
          from w'_writes have adal_w': "(ad, al)  action_loc P (llist_of E'') w'" by(simp add: writes_def)
          from w'_writes have "w'  write_actions (llist_of E'')"
            unfolding writes_def by blast
          then obtain "is_write_action (action_obs (llist_of E'') w')" 
            and w'_actions: "w'  actions (llist_of E'')" by cases
          hence "v'  w_values P (λ_. {}) (map snd E'') (ad, al)"
          proof cases
            case (NewHeapElem ad' CTn)
            hence "NormalAction (NewHeapElem ad' CTn)  set (map snd E'')"
              using w'_actions unfolding in_set_conv_nth
              by(auto simp add: actions_def action_obs_def cong: conj_cong)
            moreover have "ad' = ad" 
              and "(ad, al)  action_loc_aux P (NormalAction (NewHeapElem ad CTn))"
              using adal_w' NewHeapElem by auto
            ultimately show ?thesis using NewHeapElem unfolding v'_def
              by(simp add: value_written.simps w_values_new_actionD)
          next
            case (WriteMem ad' al' v'')
            hence "NormalAction (WriteMem ad' al' v'')  set (map snd E'')"
              using w'_actions unfolding in_set_conv_nth
              by(auto simp add: actions_def action_obs_def cong: conj_cong)
            moreover have "ad' = ad" "al' = al" using adal_w' WriteMem by auto
            ultimately show ?thesis using WriteMem unfolding v'_def
              by(simp add: value_written.simps w_values_WriteMemD)
          qed
          hence "v'  w_values P vs (concat (map (λ(t, ta). tao) ttas) @ take (i + j) ta'o) (ad, al)"
            using j ta'_j eq unfolding E''_def vs_def
            by(simp add: o_def split_def map_concat take_add take_Suc_conv_app_nth)
          from if.non_speculative_readD[OF nsr Red ns[folded vs_def] tst red' aok' j nsi' ta'_j this]
          obtain ta'' x'' m'' 
            where red'': "t  (x, shr s') -ta''→i (x'', m'')"
            and aok'': "mthr.if.actions_ok s' t ta''"
            and j': "i + j < length ta''o"
            and eq': "take (i + j) ta''o = take (i + j) ta'o"
            and ta''_j: "ta''o ! (i + j) = NormalAction (ReadMem ad al v')"
            and len': "length ta''o  max n (length ta'o)" by blast

          define EE where "EE = ?E @ map (Pair t) (take j (drop i ta''o))"
          define E' where "E' = ?E @ map (Pair t) (take j (drop i ta''o)) @ [(t, NormalAction (ReadMem ad al v'))]"

          from len' len have "length ta''o  max n (length tao)" by simp
          moreover from eq' eq j j' have "take i ta''o = take i tao"
            by(auto simp add: take_add min_def)
          moreover {
            note hb
            also have eq'': "take j (drop i ta'o) = take j (drop i ta''o)"
              using eq' j j' by(simp add: take_add min_def)
            also have "ta_hb_consistent P (?E @ list_of (llist_of (map (Pair t) (take j (drop i ta''o))))) (llist_of [(t, ta''o ! (i + j))])"
              unfolding llist_of.simps ta_hb_consistent_LCons ta_hb_consistent_LNil ta''_j prod.simps action.simps obs_event.simps list_of_llist_of append_assoc E'_def[symmetric, unfolded append_assoc]
              unfolding EE_def[symmetric, unfolded append_assoc]
            proof(intro conjI TrueI exI[where x=w'] strip)
              have "llist_of E'' [≈] llist_of E'" using j len eq'' ta'_j unfolding E''_def E'_def
                by(auto simp add: sim_actions_def list_all2_append List.list_all2_refl split_beta take_Suc_conv_app_nth take_map[symmetric])
              moreover have "length E'' = length E'" using j j' by(simp add: E''_def E'_def)
              ultimately have sim: "ltake (enat (length E')) (llist_of E'') [≈] ltake (enat (length E')) (llist_of E')" by simp

              from w'_actions ‹length E'' = length E'
              have w'_len: "w' < length E'" by(simp add: actions_def)

              from w'  write_actions (llist_of E'') sim
              show "w'  write_actions (llist_of E')" by(rule write_actions_change_prefix)(simp add: w'_len)
              from adal_w' action_loc_change_prefix[OF sim, of w' P]
              show "(ad, al)  action_loc P (llist_of E') w'" by(simp add: w'_len)

              from ta'_j j have "length ?E + j  read_actions (llist_of E'')"
                by(auto intro!: read_actions.intros simp add: action_obs_def actions_def E''_def min_def nth_append)(auto)
              hence "w'  length ?E + j" using w'  write_actions (llist_of E'')
                by(auto dest: read_actions_not_write_actions)
              with w'_len have "w' < length ?E + j" by(simp add: E'_def)
              from j j' len' eq''
              have "ltake (enat (length ?E + j)) (llist_of E'') = ltake (enat (length ?E + j)) (llist_of E')"
                by(auto simp add: E''_def E'_def min_def take_Suc_conv_app_nth)
              from value_written_change_prefix[OF this, of w' P] w' < length ?E + j
              show "value_written P (llist_of E') w' (ad, al) = v'" unfolding v'_def by simp

              from ‹thread_start_actions_ok (llist_of E'') ‹llist_of E'' [≈] llist_of E'
              have tsa'': "thread_start_actions_ok (llist_of E')"
                by(rule thread_start_actions_ok_change)
                
              from w'_writes j j' len len' have "P,llist_of E''  w' ≤hb length EE"
                by(auto simp add: EE_def writes_def min_def ac_simps)
              thus "P,llist_of E'  w' ≤hb length EE" using tsa'' sim
                by(rule happens_before_change_prefix)(simp add: w'_len, simp add: EE_def E'_def)
              
              fix w''
              assume w'': "w''  write_actions (llist_of E')"
                and adal_w'': "(ad, al)  action_loc P (llist_of E') w''"

              from w'' have w''_len: "w'' < length E'" by(cases)(simp add: actions_def)
              
              from w'' sim[symmetric] have w'': "w''  write_actions (llist_of E'')"
                by(rule write_actions_change_prefix)(simp add: w''_len)
              from adal_w'' action_loc_change_prefix[OF sim[symmetric], of w'' P] w''_len
              have adal_w'': "(ad, al)  action_loc P (llist_of E'') w''" by simp
              {
                presume w'_w'': "llist_of E'  w' ≤a w''"
                  and w''_hb: "P,llist_of E'  w'' ≤hb length EE"
                from w''_hb ‹thread_start_actions_ok (llist_of E'') sim[symmetric]
                have "P,llist_of E''  w'' ≤hb length EE"
                  by(rule happens_before_change_prefix)(simp add: w''_len, simp add: E'_def EE_def)
                with w'' adal_w'' j j' len len' have "w''  writes"
                  by(auto simp add: writes_def EE_def min_def ac_simps split: if_split_asm)
                hence "llist_of E''  w'' ≤a w'" by(rule w'_maximal)
                hence "llist_of E'  w'' ≤a w'" using sim
                  by(rule action_order_change_prefix)(simp_all add: w'_len w''_len)
                thus "w'' = w'" "w'' = w'" using w'_w'' by(rule antisymPD[OF antisym_action_order])+ 
              }

              { assume "P,llist_of E'  w' ≤hb w''  P,llist_of E'  w'' ≤hb length EE"
                thus "llist_of E'  w' ≤a w''" "P,llist_of E'  w'' ≤hb length EE"
                  by(blast dest: happens_before_into_action_order)+ }
              { assume "is_volatile P al  P,llist_of E'  w' ≤so w''  P,llist_of E'  w'' ≤so length EE"
                then obtain vol: "is_volatile P al"
                  and so: "P,llist_of E'  w' ≤so w''" 
                  and so': "P,llist_of E'  w'' ≤so length EE" by blast
                from so show "llist_of E'  w' ≤a w''" by(blast elim: sync_orderE)

                show "P,llist_of E'  w'' ≤hb length EE"
                proof(cases "is_new_action (action_obs (llist_of E') w'')")
                  case True
                  with w''  write_actions (llist_of E') ta''_j show ?thesis
                    by cases(rule happens_before_new_not_new[OF tsa''], auto simp add: actions_def EE_def E'_def action_obs_def min_def nth_append)
                next
                  case False
                  with w''  write_actions (llist_of E') (ad, al)  action_loc P (llist_of E') w''
                  obtain v'' where "action_obs (llist_of E') w'' = NormalAction (WriteMem ad al v'')"
                    by cases(auto elim: is_write_action.cases)
                  with ta''_j w'' j j' len len'
                  have "P  (action_tid (llist_of E') w'', action_obs (llist_of E') w'') ↝sw (action_tid (llist_of E') (length EE), action_obs (llist_of E') (length EE))"
                    by(auto simp add: E'_def EE_def action_obs_def min_def nth_append Volatile)
                  with so' have "P,llist_of E'  w'' ≤sw length EE" by(rule sync_withI)
                  thus ?thesis unfolding po_sw_def [abs_def] by(blast intro: tranclp.r_into_trancl)
                qed }
            qed
            ultimately have "ta_hb_consistent P ?E (lappend (llist_of (map (Pair t) (take j (drop i ta''o)))) (llist_of ([(t, ta''o ! (i + j))])))"
              by(rule ta_hb_consistent_lappendI) simp
            hence "ta_hb_consistent P ?E (llist_of (map (Pair t) (take (Suc j) (drop i ta''o))))"
              using j' unfolding lappend_llist_of_llist_of by(simp add: take_Suc_conv_app_nth) }
          moreover from len_i have "i < length tao  i < length ta''o" using eq' j' by auto
          moreover from sim_i eq' ta''_j ta'_j
          have "(if ad al v. tao ! i = NormalAction (ReadMem ad al v) then sim_action else (=)) (tao ! i) (ta''o ! i)"
            by(cases "j = 0")(auto split: if_split_asm, (metis add_strict_left_mono add_0_right nth_take)+)
          ultimately show ?thesis using red'' aok'' by blast
        next
          case False
          hence "ta_hb_consistent P (?E @ list_of (llist_of (map (Pair t) (take j (drop i ta'o))))) (llist_of [(t, ta'o ! (i + j))])"
            by(simp add: ta_hb_consistent_LCons split: action.split obs_event.split)
          with hb
          have "ta_hb_consistent P ?E (lappend (llist_of (map (Pair t) (take j (drop i ta'o)))) (llist_of ([(t, ta'o ! (i + j))])))"
            by(rule ta_hb_consistent_lappendI) simp
          hence "ta_hb_consistent P ?E (llist_of (map (Pair t) (take (Suc j) (drop i ta'o))))"
            using j unfolding lappend_llist_of_llist_of by(simp add: take_Suc_conv_app_nth)
          with red' aok' len eq len_i sim_i show ?thesis by blast
        qed
      qed
    qed }
  from this[of "max n (length tao)"]
  show "ta' x'' m''. t  (x, shr s') -ta'→i (x'', m'')  mthr.if.actions_ok s' t ta'  
                      take i ta'o = take i tao  
                      ta_hb_consistent P ?E (llist_of (map (Pair t) (drop i ta'o)))  
                      (i < length tao  i < length ta'o) 
                      (if ad al v. tao ! i = NormalAction (ReadMem ad al v) then sim_action else (=)) (tao ! i) (ta'o ! i)"
    by(simp del: split_paired_Ex cong: conj_cong split del: if_split) blast
qed

end

end

Theory JMM_Typesafe

(*  Title:      JinjaThreads/MM/JMM_Typesafe.thy
    Author:     Andreas Lochbihler
*)

section ‹Type-safety proof for the Java memory model›

theory JMM_Typesafe 
imports
  JMM_Framework
begin

text ‹
  Create a dynamic list heap_independent› of theorems for replacing 
  heap-dependent constants by heap-independent ones. 
›
ML structure Heap_Independent_Rules = Named_Thms
(
  val name = @{binding heap_independent}
  val description = "Simplification rules for heap-independent constants"
)
setup Heap_Independent_Rules.setup

locale heap_base' = 
  h: heap_base 
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate "λ_. typeof_addr" heap_read heap_write
  for addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
begin

definition typeof_h :: "'addr val  ty option"
where "typeof_h = h.typeof_h undefined"
lemma typeof_h_conv_typeof_h [heap_independent, iff]: "h.typeof_h h = typeof_h"
by(rule ext)(case_tac x, simp_all add: typeof_h_def)
lemmas typeof_h_simps [simp] = h.typeof_h.simps [unfolded heap_independent]

definition cname_of :: "'addr  cname"
where "cname_of = h.cname_of undefined"
lemma cname_of_conv_cname_of [heap_independent, iff]: "h.cname_of h = cname_of"
by(simp add: cname_of_def h.cname_of_def[abs_def])

definition addr_loc_type :: "'m prog  'addr  addr_loc  ty  bool"
where "addr_loc_type P = h.addr_loc_type P undefined"
notation addr_loc_type ("_  _@_ : _" [50, 50, 50, 50] 51)
lemma addr_loc_type_conv_addr_loc_type [heap_independent, iff]: 
  "h.addr_loc_type P h = addr_loc_type P"
by(simp add: addr_loc_type_def h.addr_loc_type_def)
lemmas addr_loc_type_cases [cases pred: addr_loc_type] = 
  h.addr_loc_type.cases[unfolded heap_independent]
lemmas addr_loc_type_intros = h.addr_loc_type.intros[unfolded heap_independent]

definition typeof_addr_loc :: "'m prog  'addr  addr_loc  ty"
where "typeof_addr_loc P = h.typeof_addr_loc P undefined"
lemma typeof_addr_loc_conv_typeof_addr_loc [heap_independent, iff]:
  "h.typeof_addr_loc P h = typeof_addr_loc P"
by(simp add: typeof_addr_loc_def h.typeof_addr_loc_def[abs_def])

definition conf :: "'a prog  'addr val  ty  bool"
where "conf P  h.conf P undefined"
notation conf ("_  _ :≤ _"  [51,51,51] 50)
lemma conf_conv_conf [heap_independent, iff]: "h.conf P h = conf P"
by(simp add: conf_def heap_base.conf_def[abs_def])
lemmas defval_conf [simp] = h.defval_conf[unfolded heap_independent]

definition lconf :: "'m prog  (vname  'addr val)  (vname  ty)  bool" 
where "lconf P = h.lconf P undefined"
notation lconf ("_  _ '(:≤') _" [51,51,51] 50)
lemma lconf_conv_lconf [heap_independent, iff]: "h.lconf P h = lconf P"
by(simp add: lconf_def h.lconf_def[abs_def])

definition confs :: "'m prog  'addr val list  ty list  bool"
where "confs P = h.confs P undefined"
notation confs ("_  _ [:≤] _" [51,51,51] 50)
lemma confs_conv_confs [heap_independent, iff]: "h.confs P h = confs P"
by(simp add: confs_def)

definition tconf :: "'m prog  'thread_id  bool" 
where "tconf P = h.tconf P undefined"
notation tconf ("_  _ √t" [51,51] 50)
lemma tconf_conv_tconf [heap_independent, iff]: "h.tconf P h = tconf P"
by(simp add: tconf_def h.tconf_def[abs_def])

definition vs_conf :: "'m prog  ('addr × addr_loc  'addr val set)  bool"
where "vs_conf P = h.vs_conf P undefined"
lemma vs_conf_conv_vs_conf [heap_independent, iff]: "h.vs_conf P h = vs_conf P"
by(simp add: vs_conf_def h.vs_conf_def[abs_def])

lemmas vs_confI = h.vs_confI[unfolded heap_independent]
lemmas vs_confD = h.vs_confD[unfolded heap_independent]

text ‹
  use non-speculativity to express that only type-correct values are read
›

primrec vs_type_all :: "'m prog  'addr × addr_loc  'addr val set"
where "vs_type_all P (ad, al) = {v. T. P  ad@al : T  P  v :≤ T}"

lemma vs_conf_vs_type_all [simp]: "vs_conf P (vs_type_all P)"
by(rule h.vs_confI[unfolded heap_independent])(simp)

lemma w_addrs_vs_type_all: "w_addrs (vs_type_all P)  dom typeof_addr"
by(auto simp add: w_addrs_def h.conf_def[unfolded heap_independent])

lemma w_addrs_vs_type_all_in_vs_type_all:
  "(ad  w_addrs (vs_type_all P). {(ad, al)|al. T. P  ad@al : T})  {adal. vs_type_all P adal  {}}"
by(auto simp add: w_addrs_def vs_type_all_def intro: defval_conf)

declare vs_type_all.simps [simp del]

lemmas vs_conf_insert_iff = h.vs_conf_insert_iff[unfolded heap_independent]

end


locale heap' =
  h: heap
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate "λ_. typeof_addr" heap_read heap_write
    P
  for addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and P :: "'m prog"

sublocale heap' < heap_base' .

context heap' begin

lemma vs_conf_w_value_WriteMemD: 
  " vs_conf P (w_value P vs ob); ob = NormalAction (WriteMem ad al v) 
   T. P  ad@al : T  P  v :≤ T"
by(auto elim: vs_confD)

lemma vs_conf_w_values_WriteMemD:
  " vs_conf P (w_values P vs obs); NormalAction (WriteMem ad al v)  set obs 
   T. P  ad@al : T  P  v :≤ T"
apply(induct obs arbitrary: vs)
apply(auto 4 3 elim: vs_confD intro: w_values_mono[THEN subsetD])
done

lemma w_values_vs_type_all_start_heap_obs:
  assumes wf: "wf_syscls P"
  shows "w_values P (vs_type_all P) (map snd (lift_start_obs h.start_tid h.start_heap_obs)) = vs_type_all P"
  (is "?lhs = ?rhs")
proof(rule antisym, rule le_funI, rule subsetI)
  fix adal v
  assume v: "v  ?lhs adal"
  obtain ad al where adal: "adal = (ad, al)" by(cases adal)
  show "v  ?rhs adal"
  proof(rule ccontr)
    assume v': "¬ ?thesis"
    from in_w_valuesD[OF v[unfolded adal] this[unfolded adal]]
    obtain obs' wa obs''
      where eq: "map snd (lift_start_obs h.start_tid h.start_heap_obs) = obs' @ wa # obs''"
      and "write": "is_write_action wa"
      and loc: "(ad, al)  action_loc_aux P wa"
      and vwa: "value_written_aux P wa al = v"
      by blast+
    from "write" show False
    proof cases
      case (WriteMem ad' al' v')
      with vwa loc eq have "WriteMem ad al v  set h.start_heap_obs"
        by(auto simp add: map_eq_append_conv Cons_eq_append_conv lift_start_obs_def)
      from h.start_heap_write_typeable[OF this] v' adal
      show ?thesis by(auto simp add: vs_type_all_def)
    next
      case (NewHeapElem ad' hT)
      with vwa loc eq have "NewHeapElem ad hT  set h.start_heap_obs"
        by(auto simp add: map_eq_append_conv Cons_eq_append_conv lift_start_obs_def)
      hence "typeof_addr ad = hT"
        by(rule h.NewHeapElem_start_heap_obsD[OF wf])
      with v' adal loc vwa NewHeapElem show ?thesis
        by(auto  simp add: vs_type_all_def intro: addr_loc_type_intros h.addr_loc_default_conf[unfolded heap_independent])
    qed
  qed
qed(rule w_values_greater)

end


lemma lprefix_lappend2I: "lprefix xs ys  lprefix xs (lappend ys zs)"
by(auto simp add: lappend_assoc lprefix_conv_lappend)

locale known_addrs_typing' =
  h: known_addrs_typing
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate "λ_. typeof_addr" heap_read heap_write 
    allocated known_addrs 
    final r wfx
    P
  for addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool" 
  and allocated :: "'heap  'addr set"
  and known_addrs :: "'thread_id  'x  'addr set"
  and final :: "'x  bool"
  and r :: "('addr, 'thread_id, 'x, 'heap, 'addr, ('addr, 'thread_id) obs_event) semantics" ("_  _ -_ _" [50,0,0,50] 80) 
  and wfx :: "'thread_id  'x  'heap  bool"
  and P :: "'md prog"
  +
  assumes NewHeapElem_typed: ― ‹Should this be moved to known\_addrs\_typing?›
  " t  (x, h) -ta (x', h'); NewHeapElem ad CTn  set tao; typeof_addr ad  None 
   typeof_addr ad = CTn"

sublocale known_addrs_typing' < heap' by unfold_locales

context known_addrs_typing' begin

lemma known_addrs_typeable_in_vs_type_all:
  "h.if.known_addrs_state s  dom typeof_addr 
   (a  h.if.known_addrs_state s. {(a, al)|al. T. P  a@al : T})  {adal. vs_type_all P adal  {}}"
by(auto 4 4 dest: subsetD simp add: vs_type_all.simps intro: defval_conf)

lemma if_NewHeapElem_typed: 
  " t  xh -ta→i x'h'; NormalAction (NewHeapElem ad CTn)  set tao; typeof_addr ad  None 
   typeof_addr ad = CTn"
by(cases rule: h.mthr.init_fin.cases)(auto dest: NewHeapElem_typed)

lemma if_redT_NewHeapElem_typed:
  " h.mthr.if.redT s (t, ta) s'; NormalAction (NewHeapElem ad CTn)  set tao; typeof_addr ad  None 
   typeof_addr ad = CTn"
by(cases rule: h.mthr.if.redT.cases)(auto dest: if_NewHeapElem_typed)

lemma non_speculative_written_value_typeable:
  assumes wfx_start: "ts_ok wfx (thr (h.start_state f P C M vs)) h.start_heap" 
  and wfP: "wf_syscls P"
  and E: "E  h.ℰ_start f P C M vs status"
  and "write": "w  write_actions E"
  and adal: "(ad, al)  action_loc P E w"
  and ns: "non_speculative P (vs_type_all P) (lmap snd (ltake (enat w) E))"
  shows "T. P  ad@al : T  P  value_written P E w (ad, al) :≤ T"
proof -
  let ?start_state = "init_fin_lift_state status (h.start_state f P C M vs)"
    and ?start_obs = "lift_start_obs h.start_tid h.start_heap_obs"
    and ?v = "value_written P E w (ad, al)"

  from "write" have iwa: "is_write_action (action_obs E w)" by cases

  from E obtain E' where E': "E = lappend (llist_of ?start_obs) E'"
    and: "E'  h.mthr.if.ℰ ?start_state" by blast
  fromobtain E'' where E'': "E' = lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E'')"
    and Runs: "h.mthr.if.mthr.Runs ?start_state E''"
    by-(rule h.mthr.if.ℰ.cases[OF])
  
  have wfx': "ts_ok (init_fin_lift wfx) (thr ?start_state) (shr ?start_state)"
    using wfx_start by(simp add: h.shr_start_state)

  from ns E'
  have ns: "non_speculative P (vs_type_all P) (lmap snd (ldropn (length (lift_start_obs h.start_tid h.start_heap_obs)) (ltake (enat w) E)))"
    by(subst (asm) lappend_ltake_ldrop[where n="enat (length (lift_start_obs h.start_tid h.start_heap_obs))", symmetric])(simp add: non_speculative_lappend min_def ltake_lappend1 w_values_vs_type_all_start_heap_obs[OF wfP] ldrop_enat split: if_split_asm)

  show ?thesis
  proof(cases "w < length ?start_obs")
    case True
    hence in_start: "action_obs E w  set (map snd ?start_obs)"
      unfolding in_set_conv_nth E' by(simp add: lnth_lappend action_obs_def map_nth exI[where x="w"])
    
    from iwa show ?thesis
    proof(cases)
      case (WriteMem ad' al' v')
      with adal have "ad' = ad" "al' = al" "?v = v'" by(simp_all add: value_written.simps)
      with WriteMem in_start have "WriteMem ad al ?v  set h.start_heap_obs" by auto
      thus ?thesis by(rule h.start_heap_write_typeable[unfolded heap_independent])
    next
      case (NewHeapElem ad' CTn)
      with adal have [simp]: "ad' = ad" by auto
      with NewHeapElem in_start have "NewHeapElem ad CTn  set h.start_heap_obs" by auto
      with wfP have "typeof_addr ad = CTn" by(rule h.NewHeapElem_start_heap_obsD)
      with adal NewHeapElem show ?thesis
        by(cases al)(auto simp add: value_written.simps intro: addr_loc_type_intros h.addr_loc_default_conf[unfolded heap_independent])
    qed
  next
    case False
    define w' where "w' = w - length ?start_obs"
    with "write" False have w'_len: "enat w' < llength E'"
      by(cases "llength E'")(auto simp add: actions_def E' elim: write_actions.cases)
    with Runs obtain m_w n_w t_w ta_w 
      where E'_w: "lnth E' w' = (t_w, ta_wo ! n_w)"
      and n_w: "n_w < length ta_wo"
      and m_w: "enat m_w < llength E''"
      and w_sum: "w' = (i<m_w. length snd (lnth E'' i)o) + n_w"
      and E''_m_w: "lnth E'' m_w = (t_w, ta_w)"
      unfolding E'' by(rule h.mthr.if.actions_ℰE_aux)

    from E'_w have obs_w: "action_obs E w = ta_wo ! n_w"
      using False E' w'_def by(simp add: action_obs_def lnth_lappend)
    
    let ?E'' = "ldropn (Suc m_w) E''"
    let ?m_E'' = "ltake (enat m_w) E''"
    have E'_unfold: "E'' = lappend ?m_E'' (LCons (lnth E'' m_w) ?E'')"
      unfolding ldropn_Suc_conv_ldropn[OF m_w] by simp
    hence "h.mthr.if.mthr.Runs ?start_state (lappend ?m_E'' (LCons (lnth E'' m_w) ?E''))"
      using Runs by simp
    then obtain σ' where σ_σ': "h.mthr.if.mthr.Trsys ?start_state (list_of ?m_E'') σ'"
      and Runs': "h.mthr.if.mthr.Runs σ' (LCons (lnth E'' m_w) ?E'')"
      by(rule h.mthr.if.mthr.Runs_lappendE) simp
    from Runs' obtain σ''' where red_w: "h.mthr.if.redT σ' (t_w, ta_w) σ'''"
      and Runs'': "h.mthr.if.mthr.Runs σ''' ?E''"
      unfolding E''_m_w by cases

    let ?EE'' = "lmap snd (lappend (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) ?m_E'')) (llist_of (map (Pair t_w) (take (n_w + 1) ta_wo))))"
    have len_EE'': "llength ?EE'' = enat (w' + 1)" using n_w m_w
      apply(simp add: w_sum)
      apply(subst llength_lconcat_lfinite_conv_sum)
      apply(simp_all add: split_beta plus_enat_simps(1)[symmetric] add_Suc_right[symmetric] del: plus_enat_simps(1) add_Suc_right)
      apply(subst sum_hom[symmetric, where f=enat])
      apply(simp_all add: zero_enat_def min_def le_Suc_eq)
      apply(rule sum.cong)
      apply(auto simp add: lnth_ltake less_trans[where y="enat m_w"])
      done
    have prefix: "lprefix ?EE'' (lmap snd E')" unfolding E''
      by(subst (2) E'_unfold)(rule lmap_lprefix, clarsimp simp add: lmap_lappend_distrib E''_m_w lprefix_lappend2I[OF lprefix_llist_ofI[OF exI[where x="map (Pair t_w) (drop (n_w + 1) ta_wo)"]]] map_append[symmetric])

    from iwa False have iwa': "is_write_action (action_obs E' w')" by(simp add: E' action_obs_def lnth_lappend w'_def)
    from ns False
    have "non_speculative P (vs_type_all P) (lmap snd (ltake (enat w') E'))"
      by(simp add: E' ltake_lappend lmap_lappend_distrib non_speculative_lappend ldropn_lappend2 w'_def)
    with iwa'
    have "non_speculative P (vs_type_all P) (lappend (lmap snd (ltake (enat w') E')) (LCons (action_obs E' w') LNil))"
      by cases(simp_all add: non_speculative_lappend)
    also have "lappend (lmap snd (ltake (enat w') E')) (LCons (action_obs E' w') LNil) = lmap snd (ltake (enat (w' + 1)) E')"
      using w'_len by(simp add: ltake_Suc_conv_snoc_lnth lmap_lappend_distrib action_obs_def)
    also {
      have "lprefix (lmap snd (ltake (enat (w' + 1)) E')) (lmap snd E')" by(rule lmap_lprefix) simp
      with prefix have "lprefix ?EE'' (lmap snd (ltake (enat (w' + 1)) E'))  
        lprefix (lmap snd (ltake (enat (w' + 1)) E')) ?EE''"
        by(rule lprefix_down_linear)
      moreover have "llength (lmap snd (ltake (enat (w' + 1)) E')) = enat (w' + 1)"
        using w'_len by(cases "llength E'") simp_all
      ultimately have "lmap snd (ltake (enat (w' + 1)) E') = ?EE''"
        using len_EE'' by(auto dest: lprefix_llength_eq_imp_eq) }
    finally
    have ns1: "non_speculative P (vs_type_all P) (llist_of (concat (map (λ(t, ta). tao) (list_of ?m_E''))))"
      and ns2: "non_speculative P (w_values P (vs_type_all P) (map snd (list_of (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) ?m_E''))))) (llist_of (take (Suc n_w) ta_wo))"
      by(simp_all add: lmap_lappend_distrib non_speculative_lappend split_beta lconcat_llist_of[symmetric] lmap_lconcat llist.map_comp o_def split_def list_of_lmap[symmetric] del: list_of_lmap)

    have "vs_conf P (vs_type_all P)" by simp
    with σ_σ' wfx' ns1
    have wfx': "ts_ok (init_fin_lift wfx) (thr σ') (shr σ')"
      and vs_conf: "vs_conf P (w_values P (vs_type_all P) (concat (map (λ(t, ta). tao) (list_of ?m_E''))))"
      by(rule h.if_RedT_non_speculative_invar[unfolded h.mthr.if.RedT_def heap_independent])+
    
    have "concat (map (λ(t, ta). tao) (list_of ?m_E'')) = map snd (list_of (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) ?m_E'')))"
      by(simp add: split_def lmap_lconcat llist.map_comp o_def list_of_lconcat map_concat)
    with vs_conf have "vs_conf P (w_values P (vs_type_all P) )" by simp
    with red_w wfx' ns2
    have vs_conf': "vs_conf P (w_values P (w_values P (vs_type_all P) (map snd (list_of (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) ?m_E''))))) (take (Suc n_w) ta_wo))"
      (is "vs_conf _ ?vs'")
      by(rule h.if_redT_non_speculative_vs_conf[unfolded heap_independent])

    from len_EE'' have "enat w' < llength ?EE''" by simp
    from w'_len have "lnth ?EE'' w' = action_obs E' w'"
      using lprefix_lnthD[OF prefix ‹enat w' < llength ?EE''] by(simp add: action_obs_def)
    hence "  lset ?EE''" using ‹enat w' < llength ?EE'' unfolding lset_conv_lnth by(auto intro!: exI)
    also have "  set (map snd (list_of (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) ?m_E''))) @ take (Suc n_w) ta_wo)"
      by(auto 4 4 intro: rev_image_eqI rev_bexI simp add: split_beta lset_lconcat_lfinite dest: lset_lappend[THEN subsetD])
    also have "action_obs E' w' = action_obs E w"
      using False by(simp add: E' w'_def lnth_lappend action_obs_def)
    also note obs_w_in_set = calculation and calculation = nothing

    from iwa have "?v  w_values P (vs_type_all P) (map snd (list_of (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) ?m_E''))) @ take (Suc n_w) ta_wo) (ad, al)"
    proof(cases)
      case (WriteMem ad' al' v')
      with adal have "ad' = ad" "al' = al" "?v = v'" by(simp_all add: value_written.simps)
      with obs_w_in_set WriteMem show ?thesis
        by -(rule w_values_WriteMemD, simp)
    next
      case (NewHeapElem ad' CTn)
      with adal have [simp]: "ad' = ad" and v: "?v = addr_loc_default P CTn al" 
        by(auto simp add: value_written.simps)
      with obs_w_in_set NewHeapElem adal show ?thesis
        by(unfold v)(rule w_values_new_actionD, simp_all)
    qed
    hence "?v  ?vs' (ad, al)" by simp
    with vs_conf' show "T. P  ad@al : T  P  ?v :≤ T"
      by(rule h.vs_confD[unfolded heap_independent])
  qed
qed

lemma hb_read_value_typeable:
  assumes wfx_start: "ts_ok wfx (thr (h.start_state f P C M vs)) h.start_heap" 
    (is "ts_ok wfx (thr ?start_state) _")
  and wfP: "wf_syscls P"
  and E: "E  h.ℰ_start f P C M vs status"
  and wf: "P  (E, ws) "
  and races: "a ad al v.  enat a < llength E; action_obs E a = NormalAction (ReadMem ad al v); ¬ P,E  ws a ≤hb a 
               T. P  ad@al : T  P  v :≤ T"
  and r: "enat a < llength E"
  and read: "action_obs E a = NormalAction (ReadMem ad al v)"
  shows "T. P  ad@al : T  P  v :≤ T"
using r read
proof(induction a arbitrary: ad al v rule: less_induct)
  case (less a)
  note r = ‹enat a < llength E
    and read = ‹action_obs E a = NormalAction (ReadMem ad al v)
  show ?case
  proof(cases "P,E  ws a ≤hb a")
    case False with r read show ?thesis by(rule races)
  next
    case True
    note hb = this
    hence ao: "E  ws a ≤a a" by(rule happens_before_into_action_order)

    from wf have ws: "is_write_seen P E ws" by(rule wf_exec_is_write_seenD)
    from r have "a  actions E" by(simp add: actions_def)
    hence "a  read_actions E" using read ..
    from is_write_seenD[OF ws this read]
    have "write": "ws a  write_actions E" 
      and adal_w: "(ad, al)  action_loc P E (ws a)"
      and written: "value_written P E (ws a) (ad, al) = v" by simp_all
    from "write" have iwa: "is_write_action (action_obs E (ws a))" by cases

    let ?start_state = "init_fin_lift_state status (h.start_state f P C M vs)"
      and ?start_obs = "lift_start_obs h.start_tid h.start_heap_obs"

    show ?thesis
    proof(cases "ws a < a")
      case True
      let ?EE'' = "lmap snd (ltake (enat (ws a)) E)"

      have "non_speculative P (vs_type_all P) ?EE''"
      proof(rule non_speculative_nthI)
        fix i ad' al' v'
        assume i: "enat i < llength ?EE''"
          and nth_i: "lnth ?EE'' i = NormalAction (ReadMem ad' al' v')"
        
        from i have "i < ws a" by simp
        hence i': "i < a" using True by(simp)
        moreover
        with r have "enat i < llength E" by(metis enat_ord_code(2) order_less_trans) 
        moreover
        with nth_i i i < ws a
        have "action_obs E i = NormalAction (ReadMem ad' al' v')"
          by(simp add: action_obs_def lnth_ltake ac_simps)
        ultimately have "T. P  ad'@al' : T  P  v' :≤ T" by(rule less.IH)
        hence "v'  vs_type_all P (ad', al')" by(simp add: vs_type_all.simps)
        thus "v'  w_values P (vs_type_all P) (list_of (ltake (enat i) ?EE'')) (ad', al')"
          by(rule w_values_mono[THEN subsetD])
      qed
      with wfx_start wfP E "write" adal_w
      show ?thesis unfolding written[symmetric] by(rule non_speculative_written_value_typeable)
    next
      case False
      
      from E obtain E' where E': "E = lappend (llist_of ?start_obs) E'"
        and: "E'  h.mthr.if.ℰ ?start_state" by blast
      fromobtain E'' where E'': "E' = lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E'')"
        and Runs: "h.mthr.if.mthr.Runs ?start_state E''"
        by-(rule h.mthr.if.ℰ.cases[OF])

      have wfx': "ts_ok (init_fin_lift wfx) (thr ?start_state) (shr ?start_state)"
        using wfx_start by(simp add: h.shr_start_state)

      have a_start: "¬ a < length ?start_obs"
      proof
        assume "a < length ?start_obs"
        with read have "NormalAction (ReadMem ad al v)  snd ` set ?start_obs"
          unfolding set_map[symmetric] in_set_conv_nth
          by(auto simp add: E' lnth_lappend action_obs_def)
        hence "ReadMem ad al v  set h.start_heap_obs" by auto
        thus False by(simp add: h.start_heap_obs_not_Read)
      qed
      hence ws_a_not_le: "¬ ws a < length ?start_obs" using False by simp

      define w where "w = ws a - length ?start_obs"
      from "write" ws_a_not_le w_def
      have "enat w < llength (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E''))"
        by(cases "llength (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E''))")(auto simp add: actions_def E' E'' elim: write_actions.cases)
      with Runs obtain m_w n_w t_w ta_w 
        where E'_w: "lnth E' w = (t_w, ta_wo ! n_w)"
        and n_w: "n_w < length ta_wo"
        and m_w: "enat m_w < llength E''"
        and w_sum: "w = (i<m_w. length snd (lnth E'' i)o) + n_w"
        and E''_m_w: "lnth E'' m_w = (t_w, ta_w)"
        unfolding E'' by(rule h.mthr.if.actions_ℰE_aux)

      from E'_w have obs_w: "action_obs E (ws a) = ta_wo ! n_w"
        using ws_a_not_le E' w_def by(simp add: action_obs_def lnth_lappend)

      let ?E'' = "ldropn (Suc m_w) E''"
      let ?m_E'' = "ltake (enat m_w) E''"
      have E'_unfold: "E'' = lappend ?m_E'' (LCons (lnth E'' m_w) ?E'')"
        unfolding ldropn_Suc_conv_ldropn[OF m_w] by simp
      hence "h.mthr.if.mthr.Runs ?start_state (lappend ?m_E'' (LCons (lnth E'' m_w) ?E''))"
        using Runs by simp
      then obtain σ' where σ_σ': "h.mthr.if.mthr.Trsys ?start_state (list_of ?m_E'') σ'"
        and Runs': "h.mthr.if.mthr.Runs σ' (LCons (lnth E'' m_w) ?E'')"
        by(rule h.mthr.if.mthr.Runs_lappendE) simp
      from Runs' obtain σ''' where red_w: "h.mthr.if.redT σ' (t_w, ta_w) σ'''"
        and Runs'': "h.mthr.if.mthr.Runs σ''' ?E''"
        unfolding E''_m_w by cases

      from "write" a  read_actions E have "ws a  a" by(auto dest: read_actions_not_write_actions)
      with False have "ws a > a" by simp
      with ao have new: "is_new_action (action_obs E (ws a))"
        by(simp add: action_order_def split: if_split_asm)
      then obtain CTn where obs_w': "action_obs E (ws a) = NormalAction (NewHeapElem ad CTn)" 
        using adal_w by cases auto

      define a' where "a' = a - length ?start_obs"
      with False w_def
      have "enat a' < llength (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E''))"
        by(simp add: le_less_trans[OF _ ‹enat w < llength (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) E''))])
      with Runs obtain m_a n_a t_a ta_a 
        where E'_a: "lnth E' a' = (t_a, ta_ao ! n_a)"
        and n_a: "n_a < length ta_ao"
        and m_a: "enat m_a < llength E''"
        and a_sum: "a' = (i<m_a. length snd (lnth E'' i)o) + n_a"
        and E''_m_a: "lnth E'' m_a = (t_a, ta_a)"
        unfolding E'' by(rule h.mthr.if.actions_ℰE_aux)
        
      from a_start E'_a read have obs_a: "ta_ao ! n_a = NormalAction (ReadMem ad al v)"
        using E' w_def by(simp add: action_obs_def lnth_lappend a'_def)
      
      let ?E'' = "ldropn (Suc m_a) E''"
      let ?m_E'' = "ltake (enat m_a) E''"
      have E'_unfold: "E'' = lappend ?m_E'' (LCons (lnth E'' m_a) ?E'')"
        unfolding ldropn_Suc_conv_ldropn[OF m_a] by simp
      hence "h.mthr.if.mthr.Runs ?start_state (lappend ?m_E'' (LCons (lnth E'' m_a) ?E''))"
        using Runs by simp
      then obtain σ'' where σ_σ'': "h.mthr.if.mthr.Trsys ?start_state (list_of ?m_E'') σ''"
        and Runs'': "h.mthr.if.mthr.Runs σ'' (LCons (lnth E'' m_a) ?E'')"
        by(rule h.mthr.if.mthr.Runs_lappendE) simp
      from Runs'' obtain σ''' where red_a: "h.mthr.if.redT σ'' (t_a, ta_a) σ'''"
        and Runs'': "h.mthr.if.mthr.Runs σ''' ?E''"
        unfolding E''_m_a by cases

      let ?EE'' = "llist_of (concat (map (λ(t, ta). tao) (list_of ?m_E'')))"
      from m_a have "enat m_a  llength E''" by simp
      hence len_EE'': "llength ?EE'' = enat (a' - n_a)"
        by(simp add: a_sum length_concat sum_list_sum_nth atLeast0LessThan length_list_of_conv_the_enat min_def split_beta lnth_ltake)
      have prefix: "lprefix ?EE'' (lmap snd E')" unfolding E''
        by(subst (2) E'_unfold)(simp add: lmap_lappend_distrib  lmap_lconcat llist.map_comp o_def split_def lconcat_llist_of[symmetric] lmap_llist_of[symmetric] lprefix_lappend2I del: lmap_llist_of)
      
      have ns: "non_speculative P (vs_type_all P) ?EE''"
      proof(rule non_speculative_nthI)
        fix i ad' al' v'
        assume i: "enat i < llength ?EE''"
          and lnth_i: "lnth ?EE'' i = NormalAction (ReadMem ad' al' v')"
          and "non_speculative P (vs_type_all P) (ltake (enat i) ?EE'')"
        
        let ?i = "i + length ?start_obs"
        
        from i len_EE'' have "i < a'" by simp
        hence i': "?i < a" by(simp add: a'_def)
        moreover
        hence "enat ?i < llength E" using ‹enat a < llength E by(simp add: less_trans[where y="enat a"])
        moreover have "enat i < llength E'" using i
          by -(rule less_le_trans[OF _ lprefix_llength_le[OF prefix], simplified], simp)          
        from lprefix_lnthD[OF prefix i] lnth_i
        have "lnth (lmap snd E') i = NormalAction (ReadMem ad' al' v')" by simp
        hence "action_obs E ?i = NormalAction (ReadMem ad' al' v')" using ‹enat i < llength E'
          by(simp add: E' action_obs_def lnth_lappend E'')
        ultimately have "T. P  ad'@al' : T  P  v' :≤ T" by(rule less.IH)
        hence "v'  vs_type_all P (ad', al')" by(simp add: vs_type_all.simps)
        thus "v'  w_values P (vs_type_all P) (list_of (ltake (enat i) ?EE'')) (ad', al')"
          by(rule w_values_mono[THEN subsetD])
      qed
        
      have "vs_conf P (vs_type_all P)" by simp
      with σ_σ'' wfx' ns
      have wfx'': "ts_ok (init_fin_lift wfx) (thr σ'') (shr σ'')" 
        and vs'': "vs_conf P (w_values P (vs_type_all P) (concat (map (λ(t, ta). tao) (list_of ?m_E''))))"
        by(rule h.if_RedT_non_speculative_invar[unfolded heap_independent h.mthr.if.RedT_def])+

      note red_w moreover
      from n_w obs_w obs_w' have "NormalAction (NewHeapElem ad CTn)  set ta_wo"
        unfolding in_set_conv_nth by auto
      moreover
      have ta_a_read: "NormalAction (ReadMem ad al v)  set ta_ao"
        using n_a obs_a unfolding in_set_conv_nth by blast
      from red_a have "T. P  ad@al : T"
      proof(cases)
        case (redT_normal x x' h')
        from wfx'' ‹thr σ'' t_a = (x, no_wait_locks)
        have "init_fin_lift wfx t_a x (shr σ'')" by(rule ts_okD)
        with t_a  (x, shr σ'') -ta_a→i (x', h')
        show ?thesis using ta_a_read
          by(rule h.init_fin_red_read_typeable[unfolded heap_independent])
      next
        case redT_acquire thus ?thesis using n_a obs_a ta_a_read by auto
      qed
      hence "typeof_addr ad  None" by(auto elim: addr_loc_type_cases)
      ultimately have "typeof_addr ad = CTn" by(rule if_redT_NewHeapElem_typed)
      with written adal_w obs_w' show ?thesis
        by(cases al)(auto simp add: value_written.simps intro: addr_loc_type_intros h.addr_loc_default_conf[unfolded heap_independent])
    qed
  qed
qed

theorem 
  assumes wfx_start: "ts_ok wfx (thr (h.start_state f P C M vs)) h.start_heap" 
  and wfP: "wf_syscls P"
  and justified: "P  (E, ws) weakly_justified_by J"
  and J: "range (justifying_exec  J)  h.ℰ_start f P C M vs status"
  shows read_value_typeable_justifying:
    " 0 < n; enat a < llength (justifying_exec (J n));
      action_obs (justifying_exec (J n)) a = NormalAction (ReadMem ad al v) 
     T. P  ad@al : T  P  v :≤ T" 
  and read_value_typeable_justifed:
    " E  h.ℰ_start f P C M vs status; P  (E, ws) ;
       enat a < llength E; action_obs E a = NormalAction (ReadMem ad al v) 
     T. P  ad@al : T  P  v :≤ T"
proof -
  let ?E = "λn. justifying_exec (J n)"
    and  = "λn. action_translation (J n)"
    and ?C = "λn. committed (J n)"
    and ?ws = "λn. justifying_ws (J n)"
  let ?ℰ = "h.ℰ_start f P C M vs status"
    and ?start_obs = "lift_start_obs h.start_tid h.start_heap_obs"
  { fix a n
    assume "enat a < llength (justifying_exec (J n))"
      and "action_obs (justifying_exec (J n)) a = NormalAction (ReadMem ad al v)"
      and "n > 0"
    thus "T. P  ad@al : T  P  v :≤ T"
    proof(induction n arbitrary: a ad al v)
      case 0 thus ?case by simp
    next
      case (Suc n')
      define n where "n = Suc n'"
      with Suc have n: "0 < n" and a: "enat a < llength (?E n)"
        and a_obs: "action_obs (?E n) a = NormalAction (ReadMem ad al v)"
        by simp_all
      have wf_n: "P  (?E n, ?ws n) "
        using justified by(simp add: justification_well_formed_def)
      from J have E: "?E n  ?ℰ" 
        and E': "?E n'  ?ℰ" by auto
      from a a_obs wfx_start wfP E wf_n show ?case
      proof(rule hb_read_value_typeable[rotated -2])
        fix a' ad' al' v'
        assume a': "enat a' < llength (?E n)"
          and a'_obs: "action_obs (?E n) a' = NormalAction (ReadMem ad' al' v')"
          and nhb: "¬ P,?E n  ?ws n a' ≤hb a'"
        from a' have "a'  actions (?E n)" by(simp add: actions_def)
        hence read_a': "a'  read_actions (?E n)" using a'_obs ..
        with justified nhb have committed': " n a'   n' ` ?C n'"
          unfolding is_weakly_justified_by.simps n_def uncommitted_reads_see_hb_def by blast

        from justified have wfa_n: "wf_action_translation E (J n)"
          and wfa_n': "wf_action_translation E (J n')" by(simp_all add: wf_action_translations_def)
        hence inj_n: "inj_on ( n) (actions (?E n))"
          and inj_n': "inj_on ( n') (actions (?E n'))"
          by(blast dest: wf_action_translation_on_inj_onD)+
        from justified have C_n: "?C n  actions (?E n)"
          and C_n': "?C n'  actions (?E n')"
          and wf_n': "P  (?E n', ?ws n') "
          by(simp_all add: committed_subset_actions_def justification_well_formed_def)

        from justified have " n' ` ?C n'   n ` ?C n"
          unfolding n_def by(simp add: is_commit_sequence_def)
        with n_def committed' have " n a'   n ` ?C n" by auto
        with inj_n C_n have committed: "a'  ?C n"
          using a'  actions (?E n) by(auto dest: inj_onD)
        with justified read_a' have ws_committed: "ws ( n a')   n ` ?C n"
          by(rule weakly_justified_write_seen_hb_read_committed)

        from wf_n have ws_n: "is_write_seen P (?E n) (?ws n)" by(rule wf_exec_is_write_seenD)
        from is_write_seenD[OF this read_a' a'_obs]
        have ws_write: "?ws n a'  write_actions (?E n)"
          and adal: "(ad', al')  action_loc P (?E n) (?ws n a')"
          and written: "value_written P (?E n) (?ws n a') (ad', al') = v'" by simp_all

        define a'' where "a'' = inv_into (actions (?E n')) ( n') ( n a')"
        from C_n' n committed' have " n a'   n' ` actions (?E n')" by auto
        hence a'': " n' a'' =  n a'"
          and a''_action: "a''  actions (?E n')" using inj_n' committed' n
          by(simp_all add: a''_def f_inv_into_f inv_into_into)
        hence committed'': "a''  ?C n'" using committed' n inj_n' C_n' by(fastforce dest: inj_onD)

        from committed committed'' wfa_n wfa_n' a'' have "action_obs (?E n') a''  action_obs (?E n) a'"
          by(auto dest!: wf_action_translation_on_actionD intro: sim_action_trans sim_action_sym)
        with a'_obs committed'' C_n' have read_a'': "a''  read_actions (?E n')"
          by(auto intro: read_actions.intros)

        then obtain ad'' al'' v'' 
          where a''_obs: "action_obs (?E n') a'' = NormalAction (ReadMem ad'' al'' v'')" by cases

        from committed'' have "n' > 0" using justified 
          by(cases n')(simp_all add: is_commit_sequence_def)
        then obtain n'' where n'': "n' = Suc n''" by(cases n') simp_all

        from justified have wfa_n'': "wf_action_translation E (J n'')" by(simp add: wf_action_translations_def)
        hence inj_n'': "inj_on ( n'') (actions (?E n''))" by(blast dest: wf_action_translation_on_inj_onD)+
        from justified have C_n'': "?C n''  actions (?E n'')" by(simp add: committed_subset_actions_def)

        from justified committed' committed'' n_def read_a' read_a'' n
        have " n (?ws n (inv_into (actions (?E n)) ( n) ( n' a''))) = ws ( n' a'')"
          by(simp add: write_seen_committed_def)
        hence " n (?ws n a') = ws ( n a')" using inj_n a'  actions (?E n) by(simp add: a'')

        from ws_committed obtain w where w: "ws ( n a') =  n w" 
          and committed_w: "w  ?C n" by blast
        from committed_w C_n have "w  actions (?E n)" by blast
        hence w_def: "w = ?ws n a'" using  n (?ws n a') = ws ( n a') inj_n ws_write
          unfolding w by(auto dest: inj_onD)
        have committed_ws: "?ws n a'  ?C n" using committed_w by(simp add: w_def)

        with wfa_n have sim_ws: "action_obs (?E n) (?ws n a')  action_obs E ( n (?ws n a'))"
          by(blast dest: wf_action_translation_on_actionD)

        from wfa_n committed_ws have sim_ws: "action_obs (?E n) (?ws n a')  action_obs E ( n (?ws n a'))"
          by(blast dest: wf_action_translation_on_actionD)
        with adal have adal_E: "(ad', al')  action_loc P E ( n (?ws n a'))"
          by(simp add: action_loc_aux_sim_action)

        have "w  write_actions (?E n'). (ad', al')  action_loc P (?E n') w  value_written P (?E n') w (ad', al') = v'"
        proof(cases " n' a''   n'' ` ?C n''")
          case True
          then obtain a''' where a''': " n'' a''' =  n' a''" 
            and committed''': "a'''  ?C n''" by auto
          from committed''' C_n'' have a'''_action: "a'''  actions (?E n'')" by auto
          
          from committed'' committed''' wfa_n' wfa_n'' a''' have "action_obs (?E n'') a'''  action_obs (?E n') a''"
            by(auto dest!: wf_action_translation_on_actionD intro: sim_action_trans sim_action_sym)
          with read_a'' committed''' C_n'' have read_a''': "a'''  read_actions (?E n'')"
            by cases(auto intro: read_actions.intros)
          
          hence " n' (?ws n' (inv_into (actions (?E n')) ( n') ( n'' a'''))) = ws ( n'' a''')"
            using justified committed'''
            unfolding is_weakly_justified_by.simps n'' Let_def write_seen_committed_def by blast
          also have "inv_into (actions (?E n')) ( n') ( n'' a''') = a''"
            using a''' inj_n' a''_action by(simp)
          also note a''' also note a''
          finally have φ_n': " n' (?ws n' a'') = ws ( n a')" .
          then have "ws ( n a') =  n' (?ws n' a'')" ..
          with  n (?ws n a') = ws ( n a')[symmetric]
          have eq_ws: " n' (?ws n' a'') =  n (?ws n a')" by simp

          from wf_n'[THEN wf_exec_is_write_seenD, THEN is_write_seenD, OF read_a'' a''_obs]
          have ws_write': "?ws n' a''  write_actions (?E n')" by simp

          from justified read_a'' committed''
          have "ws ( n' a'')   n' ` ?C n'" by(rule weakly_justified_write_seen_hb_read_committed)
          then obtain w' where w': "ws ( n' a'') =  n' w'"
            and committed_w': "w'  ?C n'" by blast
          from committed_w' C_n' have "w'  actions (?E n')" by blast
          hence w'_def: "w' = ?ws n' a''" using φ_n' inj_n' ws_write'
            unfolding w' a''[symmetric] by(auto dest: inj_onD)
          with committed_w' have committed_ws'': "?ws n' a''  committed (J n')" by simp
          with committed_ws wfa_n wfa_n' eq_ws
          have "action_obs (?E n') (?ws n' a'')  action_obs (?E n) (?ws n a')"
            by(auto dest!: wf_action_translation_on_actionD intro: sim_action_trans sim_action_sym)
          hence adal_eq: "action_loc P (?E n') (?ws n' a'') = action_loc P (?E n) (?ws n a')"
            by(simp add: action_loc_aux_sim_action)
          with adal have adal': "(ad', al')  action_loc P (?E n') (?ws n' a'')" by(simp add: action_loc_aux_sim_action)
          
          from committed_ws'' have "?ws n' a''  actions (?E n')" using C_n' by blast
          with ws_write ‹action_obs (?E n') (?ws n' a'')  action_obs (?E n) (?ws n a') 
          have ws_write'': "?ws n' a''  write_actions (?E n')" 
            by(cases)(auto intro: write_actions.intros simp add: sim_action_is_write_action_eq)
          from wfa_n' committed_ws''
          have sim_ws': "action_obs (?E n') (?ws n' a'')  action_obs E ( n' (?ws n' a''))"
            by(blast dest: wf_action_translation_on_actionD)
          with adal' have adal'_E: "(ad', al')  action_loc P E ( n' (?ws n' a''))"
            by(simp add: action_loc_aux_sim_action)
          
          from justified committed_ws ws_write adal_E
          have "value_written P (?E n) (?ws n a') (ad', al') = value_written P E ( n (?ws n a')) (ad', al')"
            unfolding is_weakly_justified_by.simps Let_def value_written_committed_def by blast
          also note eq_ws[symmetric]
          also from justified committed_ws'' ws_write'' adal'_E
          have "value_written P E ( n' (?ws n' a'')) (ad', al') = value_written P (?E n') (?ws n' a'') (ad', al')"
            unfolding is_weakly_justified_by.simps Let_def value_written_committed_def by(blast dest: sym)
          finally show ?thesis using written ws_write'' adal' by auto
        next
          case False
          with justified read_a'' committed''
          have "ws ( n' a'')   n'' ` ?C n''"
            unfolding is_weakly_justified_by.simps Let_def n'' committed_reads_see_committed_writes_weak_def by blast
          with a'' obtain w where w: " n'' w = ws ( n a')"
            and committed_w: "w  ?C n''" by auto
          from justified have " n'' ` ?C n''   n' ` ?C n'" by(simp add: is_commit_sequence_def n'')
          with committed_w w[symmetric] have "ws ( n a')   n' ` ?C n'" by(auto)
          then obtain w' where w': "ws ( n a') =  n' w'" and committed_w': "w'  ?C n'" by blast
          from wfa_n' committed_w' have "action_obs (?E n') w'  action_obs E ( n' w')"
            by(blast dest: wf_action_translation_on_actionD)
          from this[folded w', folded  n (?ws n a') = ws ( n a')] sim_ws[symmetric]
          have sim_w': "action_obs (?E n') w'  action_obs (?E n) (?ws n a')" by(rule sim_action_trans)
          with ws_write committed_w' C_n' have write_w': "w'  write_actions (?E n')"
            by(cases)(auto intro!: write_actions.intros simp add: sim_action_is_write_action_eq)
          hence "value_written P (?E n') w' (ad', al') = value_written P E ( n' w') (ad', al')"
            using adal_E committed_w' justified
            unfolding  n (?ws n a') = ws ( n a') w' is_weakly_justified_by.simps Let_def value_written_committed_def by blast
          also note w'[symmetric] 
          also note  n (?ws n a') = ws ( n a')[symmetric]
          also have "value_written P E ( n (?ws n a')) (ad', al') = value_written P (?E n) (?ws n a') (ad', al')"
            using justified committed_ws ws_write adal_E 
            unfolding is_weakly_justified_by.simps Let_def value_written_committed_def by(blast dest: sym)
          also have "(ad', al')  action_loc P (?E n') w'" using sim_w' adal by(simp add: action_loc_aux_sim_action)
          ultimately show ?thesis using written write_w' by auto
        qed
        then obtain w where w: "w  write_actions (?E n')"
          and adal: "(ad', al')  action_loc P (?E n') w"
          and written: "value_written P (?E n') w (ad', al') = v'" by blast
        from w have w_len: "enat w < llength (?E n')"
          by(cases)(simp add: actions_def)

        let ?EE'' = "lmap snd (ltake (enat w) (?E n'))"
        have "non_speculative P (vs_type_all P) ?EE''"
        proof(rule non_speculative_nthI)
          fix i ad al v
          assume i: "enat i < llength ?EE''"
            and i_nth: "lnth ?EE'' i = NormalAction (ReadMem ad al v)"
            and ns: "non_speculative P (vs_type_all P) (ltake (enat i) ?EE'')"

          from i w_len have "i < w" by(simp add: min_def not_le split: if_split_asm)
          with w_len have "enat i < llength (?E n')" by(simp add: less_trans[where y="enat w"])
          moreover
          from i_nth i i < w w_len
          have "action_obs (?E n') i = NormalAction (ReadMem ad al v)"
            by(simp add: action_obs_def ac_simps less_trans[where y="enat w"] lnth_ltake)
          moreover from n'' have "0 < n'" by simp
          ultimately have "T. P  ad@al : T  P  v :≤ T" by(rule Suc.IH)
          hence "v  vs_type_all P (ad, al)" by(simp add: vs_type_all.simps)
          thus "v  w_values P (vs_type_all P) (list_of (ltake (enat i) ?EE'')) (ad, al)"
            by(rule w_values_mono[THEN subsetD])
        qed
        with wfx_start wfP E' w adal
        show "T. P  ad'@al' : T  P  v' :≤ T"
          unfolding written[symmetric] by(rule non_speculative_written_value_typeable)
      qed
    qed
  }
  note justifying = this

  assume a: "enat a < llength E"
    and read: "action_obs E a = NormalAction (ReadMem ad al v)"
    and E: "E  h.ℰ_start f P C M vs status"
    and wf: "P  (E, ws) "
  from a have action: "a  actions E" by(auto simp add: actions_def action_obs_def)
  with justified obtain n a' where a': "a =  n a'"
    and committed': "a'  ?C n" by(auto simp add: is_commit_sequence_def)
  from justified have C_n: "?C n  actions (?E n)"
    and C_Sn: "?C (Suc n)  actions (?E (Suc n))"
    and wf_tr: "wf_action_translation E (J n)" 
    and wf_tr': "wf_action_translation E (J (Suc n))"
    by(auto simp add: committed_subset_actions_def wf_action_translations_def)
  from C_n committed' have action': "a'  actions (?E n)" by blast
  from wf_tr committed' a'
  have "action_tid E a = action_tid (?E n) a'" "action_obs E a  action_obs (?E n) a'"
    by(auto simp add: wf_action_translation_on_def intro: sim_action_sym)
  with read obtain v'
    where "action_obs (?E n) a' = NormalAction (ReadMem ad al v')"
    by(clarsimp simp add: action_obs_def)
  with action' have read': "a'  read_actions (?E n)" ..

  from justified have " n ` ?C n   (Suc n) ` ?C (Suc n)"
    by(simp add: is_commit_sequence_def)
  with committed' a' have "a  " by auto
  then obtain a'' where a'': "a =  (Suc n) a''"
    and committed'': "a''  ?C (Suc n)" by auto
  from committed'' C_Sn have action'': "a''  actions (?E (Suc n))" by blast
  
  with wf_tr' have "a'' = inv_into (actions (?E (Suc n))) ( (Suc n)) a"
    by(simp add: a'' wf_action_translation_on_def)
  with justified read' committed' a' have ws_a: "ws a =  (Suc n) (?ws (Suc n) a'')"
    by(simp add: write_seen_committed_def)

  from wf_tr' committed'' a''
  have "action_tid E a = action_tid (?E (Suc n)) a''"
    and "action_obs E a  action_obs (?E (Suc n)) a''"
    by(auto simp add: wf_action_translation_on_def intro: sim_action_sym)
  with read obtain v''
    where a_obs'': "action_obs (?E (Suc n)) a'' = NormalAction (ReadMem ad al v'')"
    by(clarsimp simp add: action_obs_def)
  with action'' have read'': "a''  read_actions (?E (Suc n))"
    by(auto intro: read_actions.intros simp add: action_obs_def)

  have "a  read_actions E" "action_obs E a = NormalAction (ReadMem ad al v)"
    using action read by(auto intro: read_actions.intros simp add: action_obs_def read)
  from is_write_seenD[OF wf_exec_is_write_seenD[OF wf] this]
  have v_eq: "v = value_written P E (ws a) (ad, al)" 
    and adal: "(ad, al)  action_loc P E (ws a)" by simp_all

  from justified have "P  (?E (Suc n), ?ws (Suc n)) " by(simp add: justification_well_formed_def)
  from is_write_seenD[OF wf_exec_is_write_seenD[OF this] read'' a_obs'']
  have write'': "?ws (Suc n) a''  write_actions (?E (Suc n))" 
    and written'': "value_written P (?E (Suc n)) (?ws (Suc n) a'') (ad, al) = v''" 
    by simp_all

  from justified read'' committed'' 
  have "ws ( (Suc n) a'')   (Suc n) ` ?C (Suc n)"
    by(rule weakly_justified_write_seen_hb_read_committed)
  then obtain w where w: "ws ( (Suc n) a'') =  (Suc n) w"
    and committed_w: "w  ?C (Suc n)" by blast
  with C_Sn have "w  actions (?E (Suc n))" by blast
  moreover have "ws ( (Suc n) a'') =  (Suc n) (?ws (Suc n) a'')"
    using ws_a a'' by simp
  ultimately have w_def: "w = ?ws (Suc n) a''"
    using wf_action_translation_on_inj_onD[OF wf_tr'] write''
    unfolding w by(auto dest: inj_onD)
  with committed_w have "?ws (Suc n) a''  ?C (Suc n)" by simp
  hence "value_written P E (ws a) (ad, al) = value_written P (?E (Suc n)) (?ws (Suc n) a'') (ad, al)"
    using adal justified write'' by(simp add: value_written_committed_def ws_a)
  with v_eq written'' have "v = v''" by simp

  from read'' have "enat a'' < llength (?E (Suc n))" by(cases)(simp add: actions_def)
  thus "T. P  ad@al : T  P  v :≤ T"
    by(rule justifying)(simp_all add: a_obs'' v = v'')
qed

corollary weakly_legal_read_value_typeable:
  assumes wfx_start: "ts_ok wfx (thr (h.start_state f P C M vs)) h.start_heap" 
  and wfP: "wf_syscls P"
  and legal: "weakly_legal_execution P (h.ℰ_start f P C M vs status) (E, ws)"
  and a: "enat a < llength E"
  and read: "action_obs E a = NormalAction (ReadMem ad al v)"
  shows "T. P  ad@al : T  P  v :≤ T"
proof -
  from legal obtain J 
    where "P  (E, ws) weakly_justified_by J"
    and "range (justifying_exec  J)  h.ℰ_start f P C M vs status"
    and "E  h.ℰ_start f P C M vs status"
    and "P  (E, ws) " by(rule legal_executionE)
  with wfx_start wfP show ?thesis using a read by(rule read_value_typeable_justifed)
qed

corollary legal_read_value_typeable:
  " ts_ok wfx (thr (h.start_state f P C M vs)) h.start_heap; wf_syscls P;
     legal_execution P (h.ℰ_start f P C M vs status) (E, ws);
     enat a < llength E; action_obs E a = NormalAction (ReadMem ad al v) 
   T. P  ad@al : T  P  v :≤ T"
by(erule (1) weakly_legal_read_value_typeable)(rule legal_imp_weakly_legal_execution)

end

end

Theory JMM_Common

(*  Title:      JinjaThreads/MM/JMM_Common.thy
    Author:     Andreas Lochbihler
*)

section ‹JMM Instantiation with Jinja -- common parts›

theory JMM_Common
imports
  JMM_Framework
  JMM_Typesafe
  "../Common/BinOp"
  "../Common/ExternalCallWF"
begin

context heap begin

lemma heap_copy_loc_not_New: assumes "heap_copy_loc a a' al h ob h'"
  shows "NewHeapElem a'' x  set ob  False"
using assms
by(auto elim: heap_copy_loc.cases)

lemma heap_copies_not_New:
  assumes "heap_copies a a' als h obs h'" 
  and "NewHeapElem a'' x  set obs"
  shows "False"
using assms
by induct(auto dest: heap_copy_loc_not_New)

lemma heap_clone_New_same_addr_same:
  assumes "heap_clone P h a h' (obs, a')"
  and "obs ! i = NewHeapElem a'' x" "i < length obs"
  and "obs ! j = NewHeapElem a'' x'" "j < length obs"
  shows "i = j"
using assms
apply cases
apply(fastforce simp add: nth_Cons' gr0_conv_Suc in_set_conv_nth split: if_split_asm dest: heap_copies_not_New)+
done

lemma red_external_New_same_addr_same:
  " P,t  aM(vs), h -ta→ext va, h'; 
    tao ! i = NewHeapElem a' x; i < length tao;
    tao ! j = NewHeapElem a' x'; j < length tao 
   i = j"
by(auto elim!: red_external.cases simp add: nth_Cons' split: if_split_asm dest: heap_clone_New_same_addr_same)

lemma red_external_aggr_New_same_addr_same:
  " (ta, va, h')  red_external_aggr P t a M vs h;
    tao ! i = NewHeapElem a' x; i < length tao;
    tao ! j = NewHeapElem a' x'; j < length tao 
   i = j"
by(auto simp add: external_WT_defs.simps red_external_aggr_def nth_Cons' split: if_split_asm if_split_asm dest: heap_clone_New_same_addr_same)

lemma heap_copy_loc_read_typeable:
  assumes "heap_copy_loc a a' al h obs h'"
  and "ReadMem ad al' v  set obs"
  and "P,h  a@al : T"
  shows "ad = a  al'= al"
using assms by cases auto

lemma heap_copies_read_typeable:
  assumes "heap_copies a a' als h obs h'"
  and "ReadMem ad al' v  set obs"
  and "list_all2 (λal T. P,h  a@al : T) als Ts"
  shows "ad = a  al'  set als"
using assms
proof(induct arbitrary: Ts)
  case Nil thus ?case by simp
next
  case (Cons al h ob h' als obs h'')
  from ‹list_all2 (λal T. P,h  a@al : T) (al # als) Ts
  obtain T Ts' where Ts [simp]: "Ts = T # Ts'"
    and "P,h  a@al : T" 
    and "list_all2 (λal T. P,h  a@al : T) als Ts'"
    by(auto simp add: list_all2_Cons1)
  from ‹ReadMem ad al' v  set (ob @ obs)
  show ?case unfolding set_append Un_iff
  proof
    assume "ReadMem ad al' v  set ob"
    with ‹heap_copy_loc a a' al h ob h'
    have "ad = a  al'= al" using P,h  a@al : T
      by(rule heap_copy_loc_read_typeable)
    thus ?thesis by simp
  next
    assume "ReadMem ad al' v  set obs"
    moreover from ‹heap_copy_loc a a' al h ob h'
    have "h  h'" by(rule hext_heap_copy_loc)
    from ‹list_all2 (λal T. P,h  a@al : T) als Ts'
    have "list_all2 (λal T. P,h'  a@al : T) als Ts'"
      by(rule List.list_all2_mono)(rule addr_loc_type_hext_mono[OF _ h  h'])
    ultimately have "ad = a  al'  set als" by(rule Cons)
    thus ?thesis by simp
  qed
qed

lemma heap_clone_read_typeable:
  assumes clone: "heap_clone P h a h' (obs, a')"
  and read: "ReadMem ad al v  set obs"
  shows "ad = a  (T'. P,h  ad@al : T')"
using clone
proof cases
  case (ObjClone C H' FDTs obs')
  let ?als = "map (λ((F, D), Tm). CField D F) FDTs"
  let ?Ts = "map (λ(FD, T). fst (the (map_of FDTs FD))) FDTs"
  note ‹heap_copies a a' ?als H' obs' h'
  moreover
  from obs = NewHeapElem a' (Class_type C) # obs' read 
  have "ReadMem ad al v  set obs'" by simp
  moreover
  from (H', a')  allocate h (Class_type C) have "h  H'" by(rule hext_allocate)
  hence "typeof_addr H' a = Class_type C" using typeof_addr h a = Class_type C
    by(rule typeof_addr_hext_mono)
  hence type: "list_all2 (λal T. P,H'  a@al : T) ?als ?Ts"
    using P  C has_fields FDTs
    unfolding list_all2_map1 list_all2_map2 list_all2_refl_conv
    by(fastforce intro: addr_loc_type.intros simp add: has_field_def dest: weak_map_of_SomeI)
  ultimately have "ad = a  al  set ?als" by(rule heap_copies_read_typeable)
  hence [simp]: "ad = a" and "al  set ?als" by simp_all
  then obtain F D T where [simp]: "al = CField D F" and "((F, D), T)  set FDTs" by auto
  with type h  H' typeof_addr h a = Class_type C show ?thesis 
    unfolding list_all2_map1 list_all2_map2 list_all2_refl_conv
    by(fastforce elim!: ballE[where x="((F, D), T)"] addr_loc_type.cases dest: typeof_addr_hext_mono intro: addr_loc_type.intros)
next
  case (ArrClone T n H' FDTs obs')
  let ?als = "map (λ((F, D), Tfm). CField D F) FDTs @ map ACell [0..<n]"
  let ?Ts = "map (λ(FD, T). fst (the (map_of FDTs FD))) FDTs @ replicate n T"
  note FDTs = P  Object has_fields FDTs
  note ‹heap_copies a a' ?als H' obs' h'
  moreover from obs = NewHeapElem a' (Array_type T n) # obs' read
  have "ReadMem ad al v  set obs'" by simp
  moreover from (H', a')  allocate h (Array_type T n)
  have "h  H'" by(rule hext_allocate)
  with typeof_addr h a = Array_type T n
  have type': "typeof_addr H' a = Array_type T n"
    by(auto dest: typeof_addr_hext_mono hext_arrD)
  hence type: "list_all2 (λal T. P,H'  a@al : T) ?als ?Ts" using FDTs
    by(fastforce intro: list_all2_all_nthI addr_loc_type.intros simp add: has_field_def list_all2_append list_all2_map1 list_all2_map2 list_all2_refl_conv dest: weak_map_of_SomeI)
  ultimately have "ad = a  al  set ?als" by(rule heap_copies_read_typeable)
  hence [simp]: "ad = a" and "al  set ?als" by simp_all
  hence "al  set (map (λ((F, D), Tfm). CField D F) FDTs)  al  set (map ACell [0..<n])" by simp
  thus ?thesis
  proof
    assume "al  set (map (λ((F, D), Tfm). CField D F) FDTs)"
    then obtain F D Tfm where [simp]: "al = CField D F" and "((F, D), Tfm)  set FDTs" by auto
    with type type' h  H' typeof_addr h a = Array_type T n show ?thesis 
      by(fastforce elim!: ballE[where x="((F, D), Tfm)"] addr_loc_type.cases intro: addr_loc_type.intros simp add: list_all2_append list_all2_map1 list_all2_map2 list_all2_refl_conv)
  next
    assume "al  set (map ACell [0..<n])"
    then obtain n' where [simp]: "al = ACell n'" and "n' < n" by auto
    with type type' h  H' typeof_addr h a = Array_type T n
    show ?thesis by(fastforce dest: list_all2_nthD[where p=n'] elim: addr_loc_type.cases intro: addr_loc_type.intros)
  qed
qed

lemma red_external_read_mem_typeable:
  assumes red: "P,t  aM(vs), h -ta→ext va, h'"
  and read: "ReadMem ad al v  set tao"
  shows "T'. P,h  ad@al : T'"
using red read
by cases(fastforce dest: heap_clone_read_typeable intro: addr_loc_type.intros)+

end

context heap_conf begin

lemma heap_clone_typeof_addrD:
  assumes "heap_clone P h a h' (obs, a')"
  and "hconf h"
  shows "NewHeapElem a'' x  set obs  a'' = a'  typeof_addr h' a' = Some x"
using assms
by(fastforce elim!: heap_clone.cases dest: allocate_SomeD hext_heap_copies heap_copies_not_New typeof_addr_is_type elim: hext_objD hext_arrD)

lemma red_external_New_typeof_addrD:
  " P,t  aM(vs), h -ta→ext va, h'; NewHeapElem a' x  set tao; hconf h 
   typeof_addr h' a' = Some x"
by(erule red_external.cases)(auto dest: heap_clone_typeof_addrD)

lemma red_external_aggr_New_typeof_addrD:
  " (ta, va, h')  red_external_aggr P t a M vs h; NewHeapElem a' x  set tao;
     is_native P (the (typeof_addr h a)) M; hconf h 
   typeof_addr h' a' = Some x"
apply(auto simp add: is_native.simps external_WT_defs.simps red_external_aggr_def split: if_split_asm)
apply(blast dest: heap_clone_typeof_addrD)+
done

end

context heap_conf begin

lemma heap_copy_loc_non_speculative_typeable:
  assumes copy: "heap_copy_loc ad ad' al h obs h'"
  and sc: "non_speculative P vs (llist_of (map NormalAction obs))"
  and vs: "vs_conf P h vs"
  and hconf: "hconf h"
  and wt: "P,h  ad@al : T" "P,h  ad'@al : T"
  shows "heap_base.heap_copy_loc (heap_read_typed P) heap_write ad ad' al h obs h'"
proof -
  from copy obtain v where obs: "obs = [ReadMem ad al v, WriteMem ad' al v]"
    and read: "heap_read h ad al v" and "write": "heap_write h ad' al v h'" by cases
  from obs sc have "v  vs (ad, al)" by auto
  with vs wt have v: "P,h  v :≤ T" by(blast dest: vs_confD addr_loc_type_fun)+
  with read wt have "heap_read_typed P h ad al v"
    by(auto intro: heap_read_typedI dest: addr_loc_type_fun)
  thus ?thesis using "write" unfolding obs by(rule heap_base.heap_copy_loc.intros)
qed

lemma heap_copy_loc_non_speculative_vs_conf:
  assumes copy: "heap_copy_loc ad ad' al h obs h'"
  and sc: "non_speculative P vs (llist_of (take n (map NormalAction obs)))"
  and vs: "vs_conf P h vs"
  and hconf: "hconf h"
  and wt: "P,h  ad@al : T" "P,h  ad'@al : T"
  shows "vs_conf P h' (w_values P vs (take n (map NormalAction obs)))"
proof -
  from copy obtain v where obs: "obs = [ReadMem ad al v, WriteMem ad' al v]"
    and read: "heap_read h ad al v" and "write": "heap_write h ad' al v h'" by cases
  from "write" have hext: "h  h'" by(rule hext_heap_write)
  with vs have vs': "vs_conf P h' vs" by(rule vs_conf_hext)
  show ?thesis
  proof(cases "n > 0")
    case True
    with obs sc have "v  vs (ad, al)" by(auto simp add: take_Cons')
    with vs wt have v: "P,h  v :≤ T" by(blast dest: vs_confD addr_loc_type_fun)+
    with hext wt have "P,h'  ad'@al : T" "P,h'  v :≤ T"
      by(blast intro: addr_loc_type_hext_mono conf_hext)+
    thus ?thesis using vs' obs
      by(auto simp add: take_Cons' intro!: vs_confI split: if_split_asm dest: vs_confD)
  next
    case False thus ?thesis using vs' by simp
  qed
qed

lemma heap_copies_non_speculative_typeable:
  assumes "heap_copies ad ad' als h obs h'"
  and "non_speculative P vs (llist_of (map NormalAction obs))"
  and "vs_conf P h vs"
  and "hconf h"
  and "list_all2 (λal T. P,h  ad@al : T) als Ts" "list_all2 (λal T. P,h  ad'@al : T) als Ts"
  shows "heap_base.heap_copies (heap_read_typed P) heap_write ad ad' als h obs h'"
using assms
proof(induct arbitrary: Ts vs)
  case Nil show ?case by(auto intro: heap_base.heap_copies.intros)
next
  case (Cons al h ob h' als obs h'')
  note sc = ‹non_speculative P vs (llist_of (map NormalAction (ob @ obs)))
    and vs = ‹vs_conf P h vs
    and hconf = hconf h
    and wt = ‹list_all2 (λal T. P,h  ad@al : T) (al # als) Ts ‹list_all2 (λal T. P,h  ad'@al : T) (al # als) Ts
  
  have sc1: "non_speculative P vs (llist_of (map NormalAction ob))" 
    and sc2: "non_speculative P (w_values P vs (map NormalAction ob)) (llist_of (map NormalAction obs))"
    using sc by(simp_all add: non_speculative_lappend lappend_llist_of_llist_of[symmetric] del: lappend_llist_of_llist_of)
  from wt obtain T Ts' where Ts: "Ts = T # Ts'" 
    and wt1: "P,h  ad@al : T" "P,h  ad'@al : T"
    and wt2: "list_all2 (λal T. P,h  ad@al : T) als Ts'" "list_all2 (λal T. P,h  ad'@al : T) als Ts'"
    by(auto simp add: list_all2_Cons1)
  from ‹heap_copy_loc ad ad' al h ob h' sc1 vs hconf wt1
  have copy: "heap_base.heap_copy_loc (heap_read_typed P) heap_write ad ad' al h ob h'"
    by(rule heap_copy_loc_non_speculative_typeable)+
  from heap_copy_loc_non_speculative_vs_conf[OF ‹heap_copy_loc ad ad' al h ob h' _ vs hconf wt1, of "length ob"] sc1
  have vs': "vs_conf P h' (w_values P vs (map NormalAction ob))" by simp

  from ‹heap_copy_loc ad ad' al h ob h'
  have "h  h'" by(rule hext_heap_copy_loc)
  with wt2 have wt2': "list_all2 (λal T. P,h'  ad@al : T) als Ts'" "list_all2 (λal T. P,h'  ad'@al : T) als Ts'"
    by -(erule List.list_all2_mono[OF _ addr_loc_type_hext_mono], assumption+)+

  from copy hconf wt1 have hconf': "hconf h'"
    by(rule heap_conf_read.hconf_heap_copy_loc_mono[OF heap_conf_read_heap_read_typed])
  
  from sc2 vs' hconf' wt2' have "heap_base.heap_copies (heap_read_typed P) heap_write ad ad' als h' obs h''" by(rule Cons)
  with copy show ?case by(rule heap_base.heap_copies.Cons)
qed

lemma heap_copies_non_speculative_vs_conf:
  assumes "heap_copies ad ad' als h obs h'"
  and "non_speculative P vs (llist_of (take n (map NormalAction obs)))"
  and "vs_conf P h vs"
  and "hconf h"
  and "list_all2 (λal T. P,h  ad@al : T) als Ts" "list_all2 (λal T. P,h  ad'@al : T) als Ts"
  shows "vs_conf P h' (w_values P vs (take n (map NormalAction obs)))"
using assms
proof(induction arbitrary: Ts vs n)
  case Nil thus ?case by simp
next
  case (Cons al h ob h' als obs h'')
  note sc = ‹non_speculative P vs (llist_of (take n (map NormalAction (ob @ obs))))
    and hcl = ‹heap_copy_loc ad ad' al h ob h'
    and vs = ‹vs_conf P h vs
    and hconf = hconf h
    and wt = ‹list_all2 (λal T. P,h  ad@al : T) (al # als) Ts ‹list_all2 (λal T. P,h  ad'@al : T) (al # als) Ts
  let ?vs' = "w_values P vs (take n (map NormalAction ob))"

  from sc have sc1: "non_speculative P vs (llist_of (take n (map NormalAction ob)))"
    and sc2: "non_speculative P ?vs' (llist_of (take (n - length ob) (map NormalAction obs)))"
    by(simp_all add: lappend_llist_of_llist_of[symmetric] non_speculative_lappend del: lappend_llist_of_llist_of)
  
  from wt obtain T Ts' where Ts: "Ts = T # Ts'" 
    and wt1: "P,h  ad@al : T" "P,h  ad'@al : T"
    and wt2: "list_all2 (λal T. P,h  ad@al : T) als Ts'" "list_all2 (λal T. P,h  ad'@al : T) als Ts'"
    by(auto simp add: list_all2_Cons1)

  from hcl sc1 vs hconf wt1 have vs': "vs_conf P h' ?vs'" by(rule heap_copy_loc_non_speculative_vs_conf)

  show ?case
  proof(cases "n < length ob")
    case True
    from ‹heap_copies ad ad' als h' obs h'' have "h'  h''" by(rule hext_heap_copies)
    with vs' have "vs_conf P h'' ?vs'" by(rule vs_conf_hext)
    thus ?thesis using True by simp
  next
    case False
    note sc2 vs'
    moreover from False sc1 have sc1': "non_speculative P vs (llist_of (map NormalAction ob))" by simp
    with hcl have "heap_base.heap_copy_loc (heap_read_typed P) heap_write ad ad' al h ob h'"
      using vs hconf wt1 by(rule heap_copy_loc_non_speculative_typeable)
    hence "hconf h'" using hconf wt1
      by(rule heap_conf_read.hconf_heap_copy_loc_mono[OF heap_conf_read_heap_read_typed])
    moreover
    from hcl have "h  h'" by(rule hext_heap_copy_loc)
    with wt2 have wt2': "list_all2 (λal T. P,h'  ad@al : T) als Ts'" "list_all2 (λal T. P,h'  ad'@al : T) als Ts'"
      by -(erule List.list_all2_mono[OF _ addr_loc_type_hext_mono], assumption+)+
    ultimately have "vs_conf P h'' (w_values P ?vs' (take (n - length ob) (map NormalAction obs)))"
      by(rule Cons.IH)
    with False show ?thesis by simp
  qed
qed

lemma heap_clone_non_speculative_typeable_Some:
  assumes clone: "heap_clone P h ad h' (obs, ad')"
  and sc: "non_speculative P vs (llist_of (map NormalAction obs))"
  and vs: "vs_conf P h vs"
  and hconf: "hconf h"
  shows "heap_base.heap_clone allocate typeof_addr (heap_read_typed P) heap_write P h ad h' (obs, ad')"
using clone
proof(cases)
  case (ObjClone C h'' FDTs obs')
  note FDTs = P  C has_fields FDTs
    and obs = obs = NewHeapElem ad' (Class_type C) # obs'
  let ?als = "map (λ((F, D), Tfm). CField D F) FDTs"
  let ?Ts = "map (λ(FD, T). fst (the (map_of FDTs FD))) FDTs"
  let ?vs = "w_value P vs (NormalAction (NewHeapElem ad' (Class_type C) :: ('addr, 'thread_id) obs_event))"
  from (h'', ad')  allocate h (Class_type C) have hext: "h  h''" by(rule hext_heap_ops)
  hence type: "typeof_addr h'' ad = Class_type C" using typeof_addr h ad = Class_type C 
    by(rule typeof_addr_hext_mono)
    
  note ‹heap_copies ad ad' ?als h'' obs' h'
  moreover from sc have "non_speculative P ?vs (llist_of (map NormalAction obs'))"
    by(simp add: obs)
  moreover from P  C has_fields FDTs
  have "is_class P C" by(rule has_fields_is_class)
  hence "is_htype P (Class_type C)" by simp
  with vs (h'', ad')  allocate h (Class_type C)
  have "vs_conf P h'' ?vs" by(rule vs_conf_allocate)
  moreover from (h'', ad')  allocate h (Class_type C) hconf ‹is_htype P (Class_type C)
  have "hconf h''" by(rule hconf_allocate_mono)
  moreover from type FDTs have "list_all2 (λal T. P,h''  ad@al : T) ?als ?Ts"
    unfolding list_all2_map1 list_all2_map2 list_all2_refl_conv
    by(fastforce intro: addr_loc_type.intros simp add: has_field_def dest: weak_map_of_SomeI)
  moreover from (h'', ad')  allocate h (Class_type C) ‹is_htype P (Class_type C)
  have "typeof_addr h'' ad' = Class_type C" by(auto dest: allocate_SomeD)
  with FDTs have "list_all2 (λal T. P,h''  ad'@al : T) ?als ?Ts"
    unfolding list_all2_map1 list_all2_map2 list_all2_refl_conv
    by(fastforce intro: addr_loc_type.intros simp add: has_field_def dest: weak_map_of_SomeI)
  ultimately
  have copy: "heap_base.heap_copies (heap_read_typed P) heap_write ad ad' (map (λ((F, D), Tfm). CField D F) FDTs) h'' obs' h'"
    by(rule heap_copies_non_speculative_typeable)+
  from typeof_addr h ad = Class_type C (h'', ad')  allocate h (Class_type C) FDTs copy
  show ?thesis unfolding obs by(rule heap_base.heap_clone.intros)
next
  case (ArrClone T n h'' FDTs obs')
  note obs = obs = NewHeapElem ad' (Array_type T n) # obs'
    and new = (h'', ad')  allocate h (Array_type T n)
    and FDTs = P  Object has_fields FDTs
  let ?als = "map (λ((F, D), Tfm). CField D F) FDTs @ map ACell [0..<n]"
  let ?Ts = "map (λ(FD, T). fst (the (map_of FDTs FD))) FDTs @ replicate n T"
  let ?vs = "w_value P vs (NormalAction (NewHeapElem ad' (Array_type T n) :: ('addr, 'thread_id) obs_event))"
  from new have hext: "h  h''" by(rule hext_heap_ops)
  hence type: "typeof_addr h'' ad = Array_type T n" using typeof_addr h ad = Array_type T n 
    by(rule typeof_addr_hext_mono)
  
  note ‹heap_copies ad ad' ?als h'' obs' h'
  moreover from sc have "non_speculative P ?vs (llist_of (map NormalAction obs'))" by(simp add: obs)
  moreover from typeof_addr h ad = Array_type T n hconf h have "is_htype P (Array_type T n)"
    by(auto dest: typeof_addr_is_type)
  with vs new have "vs_conf P h'' ?vs" by(rule vs_conf_allocate)
  moreover from new hconf ‹is_htype P (Array_type T n) have "hconf h''" by(rule hconf_allocate_mono)
  moreover
  from type FDTs have "list_all2 (λal T. P,h''  ad@al : T) ?als ?Ts"
    by(fastforce intro: list_all2_all_nthI addr_loc_type.intros simp add: has_field_def list_all2_append list_all2_map1 list_all2_map2 list_all2_refl_conv dest: weak_map_of_SomeI)
  moreover from new ‹is_htype P (Array_type T n)
  have "typeof_addr h'' ad' = Array_type T n"
    by(auto dest: allocate_SomeD)
  hence "list_all2 (λal T. P,h''  ad'@al : T) ?als ?Ts" using FDTs
    by(fastforce intro: list_all2_all_nthI addr_loc_type.intros simp add: has_field_def list_all2_append list_all2_map1 list_all2_map2 list_all2_refl_conv dest: weak_map_of_SomeI)
  ultimately have copy: "heap_base.heap_copies (heap_read_typed P) heap_write ad ad' (map (λ((F, D), Tfm). CField D F) FDTs @ map ACell [0..<n]) h'' obs' h'"
    by(rule heap_copies_non_speculative_typeable)+
  from typeof_addr h ad = Array_type T n new FDTs copy show ?thesis
    unfolding obs by(rule heap_base.heap_clone.ArrClone)
qed

lemma heap_clone_non_speculative_vs_conf_Some:
  assumes clone: "heap_clone P h ad h' (obs, ad')"
  and sc: "non_speculative P vs (llist_of (take n (map NormalAction obs)))"
  and vs: "vs_conf P h vs"
  and hconf: "hconf h"
  shows "vs_conf P h' (w_values P vs (take n (map NormalAction obs)))"
using clone
proof(cases)
  case (ObjClone C h'' FDTs obs')
  note FDTs = P  C has_fields FDTs
    and obs = obs = NewHeapElem ad' (Class_type C) # obs'
  let ?als = "map (λ((F, D), Tfm). CField D F) FDTs"
  let ?Ts = "map (λ(FD, T). fst (the (map_of FDTs FD))) FDTs"
  let ?vs = "w_value P vs (NormalAction (NewHeapElem ad' (Class_type C) :: ('addr, 'thread_id) obs_event))"
  from (h'', ad')  allocate h (Class_type C) have hext: "h  h''" by(rule hext_heap_ops)
  hence type: "typeof_addr h'' ad = Class_type C" using typeof_addr h ad = Class_type C 
    by(rule typeof_addr_hext_mono)
    
  note ‹heap_copies ad ad' ?als h'' obs' h'
  moreover from sc have "non_speculative P ?vs (llist_of (take (n - 1) (map NormalAction obs')))"
    by(simp add: obs take_Cons' split: if_split_asm)
  moreover from P  C has_fields FDTs
  have "is_class P C" by(rule has_fields_is_class)
  hence "is_htype P (Class_type C)" by simp
  with vs (h'', ad')  allocate h (Class_type C)
  have "vs_conf P h'' ?vs" by(rule vs_conf_allocate)
  moreover from (h'', ad')  allocate h (Class_type C) hconf ‹is_htype P (Class_type C)
  have "hconf h''" by(rule hconf_allocate_mono)
  moreover from type FDTs have "list_all2 (λal T. P,h''  ad@al : T) ?als ?Ts"
    unfolding list_all2_map1 list_all2_map2 list_all2_refl_conv
    by(fastforce intro: addr_loc_type.intros simp add: has_field_def dest: weak_map_of_SomeI)
  moreover from (h'', ad')  allocate h (Class_type C) ‹is_htype P (Class_type C)
  have "typeof_addr h'' ad' = Class_type C" by(auto dest: allocate_SomeD)
  with FDTs have "list_all2 (λal T. P,h''  ad'@al : T) ?als ?Ts"
    unfolding list_all2_map1 list_all2_map2 list_all2_refl_conv
    by(fastforce intro: addr_loc_type.intros simp add: has_field_def dest: weak_map_of_SomeI)
  ultimately
  have vs': "vs_conf P h' (w_values P ?vs (take (n - 1) (map NormalAction obs')))"
    by(rule heap_copies_non_speculative_vs_conf)
  show ?thesis
  proof(cases "n > 0")
    case True
    with obs vs' show ?thesis by(simp add: take_Cons')
  next
    case False
    from ‹heap_copies ad ad' ?als h'' obs' h' have "h''  h'" by(rule hext_heap_copies)
    with h  h'' have "h  h'" by(rule hext_trans)
    with vs have "vs_conf P h' vs" by(rule vs_conf_hext)
    thus ?thesis using False by simp
  qed
next
  case (ArrClone T N h'' FDTs obs')
  note obs = obs = NewHeapElem ad' (Array_type T N) # obs'
    and new = (h'', ad')  allocate h (Array_type T N)
    and FDTs = P  Object has_fields FDTs
  let ?als = "map (λ((F, D), Tfm). CField D F) FDTs @ map ACell [0..<N]"
  let ?Ts = "map (λ(FD, T). fst (the (map_of FDTs FD))) FDTs @ replicate N T"
  let ?vs = "w_value P vs (NormalAction (NewHeapElem ad' (Array_type T N) :: ('addr, 'thread_id) obs_event))"
  from new have hext: "h  h''" by(rule hext_heap_ops)
  hence type: "typeof_addr h'' ad = Array_type T N" using typeof_addr h ad = Array_type T N 
    by(rule typeof_addr_hext_mono)
  
  note ‹heap_copies ad ad' ?als h'' obs' h'
  moreover from sc have "non_speculative P ?vs (llist_of (take (n - 1) (map NormalAction obs')))"
    by(simp add: obs take_Cons' split: if_split_asm)
  moreover from typeof_addr h ad = Array_type T N hconf h have "is_htype P (Array_type T N)"
    by(auto dest: typeof_addr_is_type)
  with vs new have "vs_conf P h'' ?vs" by(rule vs_conf_allocate)
  moreover from new hconf ‹is_htype P (Array_type T N) have "hconf h''" by(rule hconf_allocate_mono)
  moreover
  from type FDTs have "list_all2 (λal T. P,h''  ad@al : T) ?als ?Ts"
    by(fastforce intro: list_all2_all_nthI addr_loc_type.intros simp add: has_field_def list_all2_append list_all2_map1 list_all2_map2 list_all2_refl_conv dest: weak_map_of_SomeI)
  moreover from new ‹is_htype P (Array_type T N)
  have "typeof_addr h'' ad' = Array_type T N"
    by(auto dest: allocate_SomeD)
  hence "list_all2 (λal T. P,h''  ad'@al : T) ?als ?Ts" using FDTs
    by(fastforce intro: list_all2_all_nthI addr_loc_type.intros simp add: has_field_def list_all2_append list_all2_map1 list_all2_map2 list_all2_refl_conv dest: weak_map_of_SomeI)
  ultimately have vs': "vs_conf P h' (w_values P ?vs (take (n - 1) (map NormalAction obs')))"
    by(rule heap_copies_non_speculative_vs_conf)
  show ?thesis
  proof(cases "n > 0")
    case True
    with obs vs' show ?thesis by(simp add: take_Cons')
  next
    case False
    from ‹heap_copies ad ad' ?als h'' obs' h' have "h''  h'" by(rule hext_heap_copies)
    with h  h'' have "h  h'" by(rule hext_trans)
    with vs have "vs_conf P h' vs" by(rule vs_conf_hext)
    thus ?thesis using False by simp
  qed
qed

lemma heap_clone_non_speculative_typeable_None:
  assumes "heap_clone P h ad h' None"
  shows "heap_base.heap_clone allocate typeof_addr (heap_read_typed P) heap_write P h ad h' None"
using assms
by(cases)(blast intro: heap_base.heap_clone.intros)+

lemma red_external_non_speculative_typeable:
  assumes red: "P,t  aM(vs), h -ta→ext va, h'"
  and sc: "non_speculative P Vs (llist_of (map NormalAction tao))"
  and vs: "vs_conf P h Vs"
  and hconf: "hconf h"
  shows "heap_base.red_external addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr (heap_read_typed P) heap_write P t h a M vs ta va h'"
using assms
by(cases)(auto intro: heap_base.red_external.intros heap_clone_non_speculative_typeable_None heap_clone_non_speculative_typeable_Some dest: hext_heap_clone elim: vs_conf_hext)

lemma red_external_non_speculative_vs_conf:
  assumes red: "P,t  aM(vs), h -ta→ext va, h'"
  and sc: "non_speculative P Vs (llist_of (take n (map NormalAction tao)))"
  and vs: "vs_conf P h Vs"
  and hconf: "hconf h"
  shows "vs_conf P h' (w_values P Vs (take n (map NormalAction tao)))"
using assms
by(cases)(auto intro: heap_base.red_external.intros heap_clone_non_speculative_vs_conf_Some dest: hext_heap_clone elim: vs_conf_hext simp add: take_Cons')

lemma red_external_aggr_non_speculative_typeable:
  assumes red: "(ta, va, h')  red_external_aggr P t a M vs h"
  and sc: "non_speculative P Vs (llist_of (map NormalAction tao))"
  and vs: "vs_conf P h Vs"
  and hconf: "hconf h"
  and native: "is_native P (the (typeof_addr h a)) M"
  shows "(ta, va, h')  heap_base.red_external_aggr addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr (heap_read_typed P) heap_write P t a M vs h"
using assms
by(cases "the (typeof_addr h a)")(auto 4 3 simp add: is_native.simps external_WT_defs.simps red_external_aggr_def heap_base.red_external_aggr_def split: if_split_asm split del: if_split del: disjCI intro: heap_clone_non_speculative_typeable_None heap_clone_non_speculative_typeable_Some dest: sees_method_decl_above)

lemma red_external_aggr_non_speculative_vs_conf:
  assumes red: "(ta, va, h')  red_external_aggr P t a M vs h"
  and sc: "non_speculative P Vs (llist_of (take n (map NormalAction tao)))"
  and vs: "vs_conf P h Vs"
  and hconf: "hconf h"
  and native: "is_native P (the (typeof_addr h a)) M"
  shows "vs_conf P h' (w_values P Vs (take n (map NormalAction tao)))"
using assms
by(cases "the (typeof_addr h a)")(auto 4 3 simp add: is_native.simps external_WT_defs.simps red_external_aggr_def heap_base.red_external_aggr_def take_Cons' split: if_split_asm split del: if_split del: disjCI intro: heap_clone_non_speculative_vs_conf_Some dest: hext_heap_clone elim: vs_conf_hext dest: sees_method_decl_above)

end

declare split_paired_Ex [simp del]
declare eq_upto_seq_inconsist_simps [simp]

context heap_progress begin

lemma heap_copy_loc_non_speculative_read:
  assumes hrt: "heap_read_typeable hconf P"
  and vs: "vs_conf P h vs"
  and type: "P,h  a@al : T" "P,h  a'@al : T"
  and hconf: "hconf h"
  and copy: "heap_copy_loc a a' al h obs h'"
  and i: "i < length obs"
  and read: "obs ! i = ReadMem a'' al'' v"
  and v: "v'  w_values P vs (map NormalAction (take i obs)) (a'', al'')"
  shows "obs' h''. heap_copy_loc a a' al h obs' h''  i < length obs'  take i obs' = take i obs  
                    obs' ! i = ReadMem a'' al'' v'  length obs'  length obs  
                    non_speculative P vs (llist_of (map NormalAction obs'))"
using copy
proof cases
  case (1 v'')
  with read i have [simp]: "i = 0" "v'' = v" "a'' = a" "al'' = al"
    by(simp_all add: nth_Cons split: nat.split_asm)
  from v have "v'  vs (a, al)" by simp
  with vs type have conf: "P,h  v' :≤ T" by(auto dest: addr_loc_type_fun vs_confD)
  let ?obs'' = "[ReadMem a al v', WriteMem a' al v']"
  from hrt type(1) conf hconf have "heap_read h a al v'" by(rule heap_read_typeableD)
  moreover from heap_write_total[OF hconf type(2) conf] 
  obtain h'' where "heap_write h a' al v' h''" ..
  ultimately have "heap_copy_loc a a' al h ?obs'' h''" ..
  thus ?thesis using 1 v'  vs (a, al) by(auto)
qed

lemma heap_copies_non_speculative_read:
  assumes hrt: "heap_read_typeable hconf P"
  and copies: "heap_copies a a' als h obs h'"
  and vs: "vs_conf P h vs"
  and type1: "list_all2 (λal T. P,h  a@al : T) als Ts"
  and type2: "list_all2 (λal T. P,h  a'@al : T) als Ts"
  and hconf: "hconf h"
  and i: "i < length obs"
  and read: "obs ! i = ReadMem a'' al'' v"
  and v: "v'  w_values P vs (map NormalAction (take i obs)) (a'', al'')"
  and ns: "non_speculative P vs (llist_of (map NormalAction (take i obs)))"
  shows "obs' h''. heap_copies a a' als h obs' h''  i < length obs'  take i obs' = take i obs  
                    obs' ! i = ReadMem a'' al'' v'  length obs'  length obs"
  (is "?concl als h obs vs i")
using copies vs type1 type2 hconf i read v ns
proof(induction arbitrary: Ts vs i)
  case Nil thus ?case by simp
next
  case (Cons al h ob h' als obs h'' Ts vs)
  note copy = ‹heap_copy_loc a a' al h ob h'
  note vs = ‹vs_conf P h vs
  note type1 = ‹list_all2 (λal T. P,h  a@al : T) (al # als) Ts
    and type2 = ‹list_all2 (λal T. P,h  a'@al : T) (al # als) Ts
  note hconf = hconf h
  note i = i < length (ob @ obs)
  note read = (ob @ obs) ! i = ReadMem a'' al'' v
  note v = v'  w_values P vs (map NormalAction (take i (ob @ obs))) (a'', al'')
  note ns = ‹non_speculative P vs (llist_of (map NormalAction (take i (ob @ obs))))

  from type1 obtain T Ts' where Ts: "Ts = T # Ts'"
    and type1': "P,h  a@al : T"
    and type1'': "list_all2 (λal T. P,h  a@al : T) als Ts'"
    by(auto simp add: list_all2_Cons1)
  from type2 Ts have type2': "P,h  a'@al : T"
    and type2'': "list_all2 (λal T. P,h  a'@al : T) als Ts'"
    by simp_all
  show ?case
  proof(cases "i < length ob")
    case True
    with read v
    have "ob ! i = ReadMem a'' al'' v"
      and "v'  w_values P vs (map NormalAction (take i ob)) (a'', al'')" by(simp_all add: nth_append)
    from heap_copy_loc_non_speculative_read[OF hrt vs type1' type2' hconf copy True this]
    obtain ob' H'' where copy': "heap_copy_loc a a' al h ob' H''"
      and i': "i < length ob'" and "take i ob' = take i ob"
      and "ob' ! i = ReadMem a'' al'' v'"
      and "length ob'  length ob"
      and ns: "non_speculative P vs (llist_of (map NormalAction ob'))" by blast
    moreover {
      from copy' have hext: "h  H''" by(rule hext_heap_copy_loc)
      have "hconf H''" 
        by(rule heap_conf_read.hconf_heap_copy_loc_mono[OF heap_conf_read_heap_read_typed])(rule heap_copy_loc_non_speculative_typeable[OF copy' ns vs hconf type1' type2'], fact+)
      moreover
      from type1'' have "list_all2 (λal T. P,H''  a@al : T) als Ts'"
        by(rule List.list_all2_mono)(rule addr_loc_type_hext_mono[OF _ hext])
      moreover from type2'' have "list_all2 (λal T. P,H''  a'@al : T) als Ts'"
        by(rule List.list_all2_mono)(rule addr_loc_type_hext_mono[OF _ hext])
      moreover note calculation }
    from heap_copies_progress[OF this]
    obtain obs' h''' where *: "heap_copies a a' als H'' obs' h'''" by blast
    moreover note heap_copies_length[OF *]
    moreover note heap_copy_loc_length[OF copy']
    moreover note heap_copies_length[OF ‹heap_copies a a' als h' obs h'']
    ultimately show ?thesis using True by(auto intro!: heap_copies.Cons exI simp add: nth_append)
  next
    case False
    let ?vs' = "w_values P vs (map NormalAction ob)"
    let ?i' = "i - length ob"

    from ns False obtain ns': "non_speculative P vs (llist_of (map NormalAction ob))"
      and ns'': "non_speculative P ?vs' (llist_of (map NormalAction (take ?i' obs)))"
      by(simp add: lappend_llist_of_llist_of[symmetric] non_speculative_lappend del: lappend_llist_of_llist_of)

    from heap_copy_loc_non_speculative_vs_conf[OF copy _ vs hconf type1' type2', where n="length ob"] ns'
    have "vs_conf P h' ?vs'" by simp
    moreover
    from copy have hext: "h  h'" by(rule hext_heap_copy_loc)
    from type1'' have "list_all2 (λal T. P,h'  a@al : T) als Ts'"
      by(rule List.list_all2_mono)(rule addr_loc_type_hext_mono[OF _ hext])
    moreover from type2'' have "list_all2 (λal T. P,h'  a'@al : T) als Ts'"
      by(rule List.list_all2_mono)(rule addr_loc_type_hext_mono[OF _ hext])
    moreover have "hconf h'" 
      by(rule heap_conf_read.hconf_heap_copy_loc_mono[OF heap_conf_read_heap_read_typed])(rule heap_copy_loc_non_speculative_typeable[OF copy ns' vs hconf type1' type2'], fact+)
    moreover from i False have "?i' < length obs" by simp
    moreover from read False have "obs ! ?i' = ReadMem a'' al'' v" by(simp add: nth_append)
    moreover from v False have "v'  w_values P ?vs' (map NormalAction (take ?i' obs)) (a'', al'')" by(simp)
    ultimately have "?concl als h' obs ?vs' ?i'" using ns'' by(rule Cons.IH)
    thus ?thesis using False copy by safe(auto intro!: heap_copies.Cons exI simp add: nth_append)
  qed
qed

lemma heap_clone_non_speculative_read:
  assumes hrt: "heap_read_typeable hconf P"
  and clone: "heap_clone P h a h' (obs, a')"
  and vs: "vs_conf P h vs"
  and hconf: "hconf h"
  and i: "i < length obs"
  and read: "obs ! i = ReadMem a'' al'' v"
  and v: "v'  w_values P vs (map NormalAction (take i obs)) (a'', al'')"
  and ns: "non_speculative P vs (llist_of (map NormalAction (take i obs)))"
  shows "obs' h''. heap_clone P h a h'' (obs', a')  i < length obs'  take i obs' = take i obs  
                    obs' ! i = ReadMem a'' al'' v'  length obs'  length obs"
using clone
proof cases
  case (ObjClone C h'' FDTs obs')

  note obs = obs = NewHeapElem a' (Class_type C) # obs'
  note FDTs = P  C has_fields FDTs
  let ?als = "map (λ((F, D), Tm). CField D F) FDTs"
  let ?Ts = "map (λ(FD, T). fst (the (map_of FDTs FD))) FDTs"
  let ?vs = "w_value P vs (NormalAction (NewHeapElem a' (Class_type C)) :: ('addr, 'thread_id) obs_event action)"
  let ?i = "i - 1"
  from i read obs have i_0: "i > 0" by(simp add: nth_Cons' split: if_split_asm)

  from P  C has_fields FDTs have "is_class P C" by(rule has_fields_is_class)
  with (h'', a')  allocate h (Class_type C)
  have type_a': "typeof_addr h'' a' = Class_type C" and hext: "h  h''"
    by(auto dest: allocate_SomeD hext_allocate)

  note ‹heap_copies a a' ?als h'' obs' h'
  moreover from typeof_addr h a = Class_type C hconf have "is_htype P (Class_type C)"
    by(rule typeof_addr_is_type)
  with vs (h'', a')  allocate h (Class_type C)
  have "vs_conf P h'' ?vs" by(rule vs_conf_allocate)
  moreover
  from hext typeof_addr h a = Class_type C
  have "typeof_addr h'' a = Class_type C" by(rule typeof_addr_hext_mono)
  hence "list_all2 (λal T. P,h''  a@al : T) ?als ?Ts" using FDTs
    unfolding list_all2_map1 list_all2_map2 list_all2_refl_conv
    by(fastforce intro: addr_loc_type.intros simp add: has_field_def dest: weak_map_of_SomeI)
  moreover from FDTs type_a'
  have "list_all2 (λal T. P,h''  a'@al : T) ?als ?Ts"
    unfolding list_all2_map1 list_all2_map2 list_all2_refl_conv
    by(fastforce intro: addr_loc_type.intros simp add: has_field_def dest: weak_map_of_SomeI)
  moreover from (h'', a')  allocate h (Class_type C) hconf ‹is_htype P (Class_type C)
  have "hconf h''" by(rule hconf_allocate_mono)
  moreover from i read i_0 obs have "?i < length obs'" "obs' ! ?i = ReadMem a'' al'' v" by simp_all
  moreover from v i_0 obs
  have "v'  w_values P ?vs (map NormalAction (take ?i obs')) (a'', al'')" by(simp add: take_Cons')
  moreover from ns i_0 obs
  have "non_speculative P ?vs (llist_of (map NormalAction (take ?i obs')))" by(simp add: take_Cons')
  ultimately have "obs'' h'''. heap_copies a a' ?als h'' obs'' h''' 
                             ?i < length obs''  take ?i obs'' = take ?i obs'  obs'' ! ?i = ReadMem a'' al'' v' 
                             length obs''  length obs'"
    by(rule heap_copies_non_speculative_read[OF hrt])
  thus ?thesis using typeof_addr h a = Class_type C (h'', a')  allocate h (Class_type C) FDTs obs i_0
    by(auto 4 4 intro: heap_clone.ObjClone simp add: take_Cons')
next
  case (ArrClone T n h'' FDTs obs')

  note obs = obs = NewHeapElem a' (Array_type T n) # obs'
  note FDTs = P  Object has_fields FDTs
  let ?als = "map (λ((F, D), Tfm). CField D F) FDTs @ map ACell [0..<n]"
  let ?Ts = "map (λ(FD, T). fst (the (map_of FDTs FD))) FDTs @ replicate n T"
  let ?vs = "w_value P vs (NormalAction (NewHeapElem a' (Array_type T n)) :: ('addr, 'thread_id) obs_event action)"
  let ?i = "i - 1"
  from i read obs have i_0: "i > 0" by(simp add: nth_Cons' split: if_split_asm)

  from typeof_addr h a = Array_type T n hconf
  have "is_htype P (Array_type T n)" by(rule typeof_addr_is_type)
  with (h'', a')  allocate h (Array_type T n)
  have type_a': "typeof_addr h'' a' = Array_type T n"
    and hext: "h  h''"
    by(auto dest: allocate_SomeD hext_allocate)

  note ‹heap_copies a a' ?als h'' obs' h'
  moreover from vs (h'', a')  allocate h (Array_type T n) ‹is_htype P (Array_type T n)
  have "vs_conf P h'' ?vs" by(rule vs_conf_allocate)
  moreover from hext typeof_addr h a = Array_type T n
  have type'a: "typeof_addr h'' a = Array_type T n"
    by(auto intro: hext_arrD)
  from type'a FDTs have "list_all2 (λal T. P,h''  a@al : T) ?als ?Ts"
    by(fastforce intro: list_all2_all_nthI addr_loc_type.intros simp add: has_field_def list_all2_append list_all2_map1 list_all2_map2 list_all2_refl_conv dest: weak_map_of_SomeI)
  moreover from type_a' FDTs
  have "list_all2 (λal T. P,h''  a'@al : T) ?als ?Ts"
    by(fastforce intro: list_all2_all_nthI addr_loc_type.intros simp add: has_field_def list_all2_append list_all2_map1 list_all2_map2 list_all2_refl_conv dest: weak_map_of_SomeI)
  moreover from (h'', a')  allocate h (Array_type T n) hconf ‹is_htype P (Array_type T n)
  have "hconf h''" by(rule hconf_allocate_mono)
  moreover from i read i_0 obs have "?i < length obs'" "obs' ! ?i = ReadMem a'' al'' v" by simp_all
  moreover from v i_0 obs
  have "v'  w_values P ?vs (map NormalAction (take ?i obs')) (a'', al'')" by(simp add: take_Cons')
  moreover from ns i_0 obs
  have "non_speculative P ?vs (llist_of (map NormalAction (take ?i obs')))" by(simp add: take_Cons')
  ultimately have "obs'' h'''. heap_copies a a' ?als h'' obs'' h''' 
                             ?i < length obs''  take ?i obs'' = take ?i obs'  obs'' ! ?i = ReadMem a'' al'' v' 
                             length obs''  length obs'"
    by(rule heap_copies_non_speculative_read[OF hrt])
  thus ?thesis using typeof_addr h a = Array_type T n (h'', a')  allocate h (Array_type T n) FDTs obs i_0
    by(auto 4 4 intro: heap_clone.ArrClone simp add: take_Cons')
qed

lemma red_external_non_speculative_read:
  assumes hrt: "heap_read_typeable hconf P"
  and vs: "vs_conf P (shr s) vs"
  and red: "P,t  aM(vs'), shr s -ta→ext va,h'"
  and aok: "final_thread.actions_ok final s t ta"
  and hconf: "hconf (shr s)"
  and i: "i < length tao"
  and read: "tao ! i = ReadMem a'' al'' v"
  and v: "v'  w_values P vs (map NormalAction (take i tao)) (a'', al'')"
  and ns: "non_speculative P vs (llist_of (map NormalAction (take i tao)))"
  shows "ta'' va'' h''. P,t  aM(vs'), shr s -ta''→ext va'', h''  final_thread.actions_ok final s t ta'' 
                         i < length ta''o  take i ta''o = take i tao  
                         ta''o ! i = ReadMem a'' al'' v'  length ta''o  length tao"
using red i read
proof cases
  case [simp]: (RedClone obs a')
  from heap_clone_non_speculative_read[OF hrt ‹heap_clone P (shr s) a h' (obs, a') vs hconf, of i a'' al'' v v'] i read v ns
  show ?thesis using aok
    by(fastforce intro: red_external.RedClone simp add: final_thread.actions_ok_iff)
qed(auto simp add: nth_Cons)

lemma red_external_aggr_non_speculative_read:
  assumes hrt: "heap_read_typeable hconf P"
  and vs: "vs_conf P (shr s) vs"
  and red: "(ta, va, h')  red_external_aggr P t a M vs' (shr s)"
  and native: "is_native P (the (typeof_addr (shr s) a)) M"
  and aok: "final_thread.actions_ok final s t ta"
  and hconf: "hconf (shr s)"
  and i: "i < length tao"
  and read: "tao ! i = ReadMem a'' al'' v"
  and v: "v'  w_values P vs (map NormalAction (take i tao)) (a'', al'')"
  and ns: "non_speculative P vs (llist_of (map NormalAction (take i tao)))"
  shows "ta'' va'' h''. (ta'', va'', h'')  red_external_aggr P t a M vs' (shr s)  final_thread.actions_ok final s t ta'' 
                         i < length ta''o  take i ta''o = take i tao  
                         ta''o ! i = ReadMem a'' al'' v'  length ta''o  length tao"
using red native aok hconf i read v ns
apply(simp add: red_external_aggr_def final_thread.actions_ok_iff ex_disj_distrib conj_disj_distribR split nth_Cons' del: if_split split: if_split_asm disj_split_asm)
apply(drule heap_clone_non_speculative_read[OF hrt _ vs hconf, of _ _ _ _ i a'' al'' v v'])
apply simp_all
apply(fastforce)
done

end

declare split_paired_Ex [simp]
declare eq_upto_seq_inconsist_simps [simp del]


context allocated_heap begin

lemma heap_copy_loc_allocated_same:
  assumes "heap_copy_loc a a' al h obs h'"
  shows "allocated h' = allocated h"
using assms
by cases(auto del: subsetI simp: heap_write_allocated_same)

lemma heap_copy_loc_allocated_mono:
  "heap_copy_loc a a' al h obs h'  allocated h  allocated h'"
by(simp add: heap_copy_loc_allocated_same)

lemma heap_copies_allocated_same:
  assumes "heap_copies a a' al h obs h'"
  shows "allocated h' = allocated h"
using assms
by(induct)(auto simp add: heap_copy_loc_allocated_same)

lemma heap_copies_allocated_mono:
  "heap_copies a a' al h obs h'  allocated h  allocated h'"
by(simp add: heap_copies_allocated_same)

lemma heap_clone_allocated_mono:
  assumes "heap_clone P h a h' aobs"
  shows "allocated h  allocated h'"
using assms
by cases(blast del: subsetI intro: heap_copies_allocated_mono allocate_allocated_mono intro: subset_trans)+

lemma red_external_allocated_mono:
  assumes "P,t  aM(vs), h -ta→ext va, h'"
  shows "allocated h  allocated h'"
using assms
by(cases)(blast del: subsetI intro: heap_clone_allocated_mono heap_write_allocated_same)+

lemma red_external_aggr_allocated_mono:
  " (ta, va, h')  red_external_aggr P t a M vs h; is_native P (the (typeof_addr h a)) M 
   allocated h  allocated h'"
by(cases "the (typeof_addr h a)")(auto simp add: is_native.simps external_WT_defs.simps red_external_aggr_def split: if_split_asm dest: heap_clone_allocated_mono sees_method_decl_above)

lemma heap_clone_allocatedD:
  assumes "heap_clone P h a h' (obs, a')"
  and "NewHeapElem a'' x  set obs"
  shows "a''  allocated h'  a''  allocated h"
using assms
by cases(auto dest: allocate_allocatedD heap_copies_allocated_mono heap_copies_not_New)

lemma red_external_allocatedD:
  " P,t  aM(vs), h -ta→ext va, h'; NewHeapElem a' x  set tao 
   a'  allocated h'  a'  allocated h"
by(erule red_external.cases)(auto dest: heap_clone_allocatedD)

lemma red_external_aggr_allocatedD:
  " (ta, va, h')  red_external_aggr P t a M vs h; NewHeapElem a' x  set tao;
     is_native P (the (typeof_addr h a)) M 
   a'  allocated h'  a'  allocated h"
by(auto simp add: is_native.simps external_WT_defs.simps red_external_aggr_def split: if_split_asm dest: heap_clone_allocatedD sees_method_decl_above)

lemma heap_clone_NewHeapElemD:
  assumes "heap_clone P h a h' (obs, a')"
  and "ad  allocated h'"
  and "ad  allocated h"
  shows "CTn. NewHeapElem ad CTn  set obs"
using assms
by cases(auto dest!: allocate_allocatedD heap_copies_allocated_same)

lemma heap_clone_fail_allocated_same:
  assumes "heap_clone P h a h' None"
  shows "allocated h' = allocated h"
using assms
by(cases)(auto)

lemma red_external_NewHeapElemD:
  " P,t  aM(vs), h -ta→ext va, h'; a'  allocated h'; a'  allocated h 
   CTn. NewHeapElem a' CTn  set tao"
by(erule red_external.cases)(auto dest: heap_clone_NewHeapElemD heap_clone_fail_allocated_same)

lemma red_external_aggr_NewHeapElemD:
  " (ta, va, h')  red_external_aggr P t a M vs h; a'  allocated h'; a'  allocated h;
     is_native P (the (typeof_addr h a)) M 
   CTn. NewHeapElem a' CTn  set tao"
by(cases "the (typeof_addr h a)")(auto simp add: is_native.simps external_WT_defs.simps red_external_aggr_def split: if_split_asm dest: heap_clone_fail_allocated_same heap_clone_NewHeapElemD sees_method_decl_above)

end

context heap_base begin

lemma binop_known_addrs:
  assumes ok: "start_heap_ok"
  shows "binop bop v1 v2 = Inl v  ka_Val v  ka_Val v1  ka_Val v2  set start_addrs"
  and "binop bop v1 v2 = Inr a  a  ka_Val v1  ka_Val v2  set start_addrs"
apply(cases bop, auto split: if_split_asm)[1]
apply(cases bop, auto split: if_split_asm simp add: addr_of_sys_xcpt_start_addr[OF ok])
done

lemma heap_copy_loc_known_addrs_ReadMem:
  assumes "heap_copy_loc a a' al h ob h'"
  and "ReadMem ad al' v  set ob"
  shows "ad = a"
using assms by cases simp

lemma heap_copies_known_addrs_ReadMem:
  assumes "heap_copies a a' als h obs h'"
  and "ReadMem ad al v  set obs"
  shows "ad = a"
using assms
by(induct)(auto dest: heap_copy_loc_known_addrs_ReadMem)

lemma heap_clone_known_addrs_ReadMem:
  assumes "heap_clone P h a h' (obs, a')"
  and "ReadMem ad al v  set obs"
  shows "ad = a"
using assms
by cases(auto dest: heap_copies_known_addrs_ReadMem)

lemma red_external_known_addrs_ReadMem:
  " P,t  aM(vs), h -ta→ext va,h'; ReadMem ad al v  set tao 
   ad  {thread_id2addr t, a}  ((ka_Val ` set vs))  set start_addrs"
by(erule red_external.cases)(simp_all add: heap_clone_known_addrs_ReadMem)

lemma red_external_aggr_known_addrs_ReadMem:
  " (ta, va, h')  red_external_aggr P t a M vs h; ReadMem ad al v  set tao 
   ad  {thread_id2addr t, a}  ((ka_Val ` set vs))  set start_addrs"
apply(auto simp add: red_external_aggr_def split: if_split_asm dest: heap_clone_known_addrs_ReadMem)
done

lemma heap_copy_loc_known_addrs_WriteMem:
  assumes "heap_copy_loc a a' al h ob h'"
  and "ob ! n = WriteMem ad al' (Addr a'')" "n < length ob"
  shows "a''  new_obs_addrs (take n ob)"
using assms
by cases(auto simp add: nth_Cons new_obs_addrs_def split: nat.split_asm)

lemma heap_copies_known_addrs_WriteMem:
  assumes "heap_copies a a' als h obs h'"
  and "obs ! n = WriteMem ad al (Addr a'')" "n < length obs"
  shows "a''  new_obs_addrs (take n obs)"
using assms
by(induct arbitrary: n)(auto simp add: nth_append new_obs_addrs_def dest: heap_copy_loc_known_addrs_WriteMem split: if_split_asm)

lemma heap_clone_known_addrs_WriteMem:
  assumes "heap_clone P h a h' (obs, a')"
  and "obs ! n = WriteMem ad al (Addr a'')" "n < length obs"
  shows "a''  new_obs_addrs (take n obs)"
using assms
by cases(auto simp add: nth_Cons new_obs_addrs_def split: nat.split_asm dest: heap_copies_known_addrs_WriteMem)

lemma red_external_known_addrs_WriteMem:
  " P,t  aM(vs), h -ta→ext va,h'; tao ! n = WriteMem ad al (Addr a'); n < length tao 
   a'  {thread_id2addr t, a}  ((ka_Val ` set vs))  set start_addrs  new_obs_addrs (take n tao)"
by(erule red_external.cases)(auto dest: heap_clone_known_addrs_WriteMem)

lemma red_external_aggr_known_addrs_WriteMem:
  " (ta, va, h')  red_external_aggr P t a M vs h;
     tao ! n = WriteMem ad al (Addr a'); n < length tao 
   a'  {thread_id2addr t, a}  ((ka_Val ` set vs))  set start_addrs  new_obs_addrs (take n tao)"
apply(auto simp add: red_external_aggr_def split: if_split_asm dest: heap_clone_known_addrs_WriteMem)
done

lemma red_external_known_addrs_mono:
  assumes ok: "start_heap_ok"
  and red: "P,t  aM(vs), h -ta→ext va, h'"
  shows "(case va of RetVal v  ka_Val v | RetExc a  {a} | RetStaySame  {})  {thread_id2addr t, a}  ((ka_Val ` set vs))  set start_addrs  new_obs_addrs tao"
using red
by cases(auto simp add: addr_of_sys_xcpt_start_addr[OF ok] new_obs_addrs_def heap_clone.simps)

lemma red_external_aggr_known_addrs_mono:
  assumes ok: "start_heap_ok"
  and red: "(ta, va, h')  red_external_aggr P t a M vs h" "is_native P (the (typeof_addr h a)) M"
  shows "(case va of RetVal v  ka_Val v | RetExc a  {a} | RetStaySame  {})  {thread_id2addr t, a}  ((ka_Val ` set vs))  set start_addrs  new_obs_addrs tao"
using red
apply(cases "the (typeof_addr h a)")
apply(auto simp add: red_external_aggr_def addr_of_sys_xcpt_start_addr[OF ok] new_obs_addrs_def heap_clone.simps split: if_split_asm)
apply(auto simp add: is_native.simps elim!: external_WT_defs.cases dest: sees_method_decl_above)
done

lemma red_external_NewThread_idD:
  " P,t  aM(vs), h -ta→ext va, h'; NewThread t' (C, M', a') h''  set tat 
   t' = addr2thread_id a  a' = a"
by(erule red_external.cases) simp_all

lemma red_external_aggr_NewThread_idD:
  " (ta, va, h')  red_external_aggr P t a M vs h; 
     NewThread t' (C, M', a') h''  set tat 
   t' = addr2thread_id a  a' = a"
apply(auto simp add: red_external_aggr_def split: if_split_asm)
done

end

locale heap'' = 
  heap'
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write
    P
  for addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and P :: "'m prog"
  +
  assumes allocate_typeof_addr_SomeD: " (h', a)  allocate h hT; typeof_addr a  None   typeof_addr a = hT"
begin

lemma heap_copy_loc_New_type_match:
  " h.heap_copy_loc a a' al h obs h'; NewHeapElem ad CTn  set obs; typeof_addr ad  None 
   typeof_addr ad = CTn"
by(erule h.heap_copy_loc.cases) simp

lemma heap_copies_New_type_match:
  " h.heap_copies a a' als h obs h'; NewHeapElem ad CTn  set obs; typeof_addr ad  None 
   typeof_addr ad = CTn"
by(induct rule: h.heap_copies.induct)(auto dest: heap_copy_loc_New_type_match)

lemma heap_clone_New_type_match:
  " h.heap_clone P h a h' (obs, a'); NewHeapElem ad CTn  set obs; typeof_addr ad  None 
   typeof_addr ad = CTn"
by(erule h.heap_clone.cases)(auto dest: allocate_typeof_addr_SomeD heap_copies_New_type_match)

lemma red_external_New_type_match:
  " h.red_external P t a M vs h ta va h'; NewHeapElem ad CTn  set tao; typeof_addr ad  None 
   typeof_addr ad = CTn"
by(erule h.red_external.cases)(auto dest: heap_clone_New_type_match)

lemma red_external_aggr_New_type_match:
  " (ta, va, h')  h.red_external_aggr P t a M vs h; NewHeapElem ad CTn  set tao; typeof_addr ad  None 
   typeof_addr ad = CTn"
by(auto simp add: h.red_external_aggr_def split: if_split_asm dest: heap_clone_New_type_match)

end

end

Theory JMM_J

theory JMM_J
imports
  JMM_Framework
  "../J/Threaded"
begin

sublocale J_heap_base < red_mthr: 
  heap_multithreaded_base 
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write
    "final_expr" "mred P" convert_RA
  for P
.

context J_heap_base begin

abbreviation J_ℰ ::
  "'addr J_prog  cname  mname  'addr val list  status 
   ('thread_id × ('addr, 'thread_id) obs_event action) llist set"
where
  "J_ℰ P  red_mthr.ℰ_start P J_local_start P"

end

end

Theory DRF_J

(*  Title:      JinjaThreads/MM/DRF_J.thy
    Author:     Andreas Lochbihler
*)

section ‹JMM Instantiation for J›

theory DRF_J
imports
  JMM_Common
  JMM_J
  "../J/ProgressThreaded"
  SC_Legal
begin

primrec ka :: "'addr expr  'addr set"
  and kas :: "'addr expr list  'addr set"
where 
  "ka (new C) = {}"
| "ka (newA Te) = ka e"
| "ka (Cast T e) = ka e"
| "ka (e instanceof T) = ka e"
| "ka (Val v) = ka_Val v"
| "ka (Var V) = {}"
| "ka (e1 «bop» e2) = ka e1  ka e2"
| "ka (V := e) = ka e"
| "ka (ae) = ka a  ka e"
| "ka (ae := e') = ka a  ka e  ka e'"
| "ka (a∙length) = ka a"
| "ka (eF{D}) = ka e"
| "ka (eF{D} := e') = ka e  ka e'"
| "ka (e∙compareAndSwap(DF, e', e'')) = ka e  ka e'  ka e''"
| "ka (eM(es)) = ka e  kas es"
| "ka {V:T=vo; e} = ka e  (case vo of None  {} | Some v  ka_Val v)"
| "ka (Synchronized x e e') = ka e  ka e'"
| "ka (InSynchronized x a e) = insert a (ka e)"
| "ka (e;; e') = ka e  ka e'"
| "ka (if (e) e1 else e2) = ka e  ka e1  ka e2"
| "ka (while (b) e) = ka b  ka e"
| "ka (throw e) = ka e"
| "ka (try e catch(C V) e') = ka e  ka e'"

| "kas [] = {}"
| "kas (e # es) = ka e  kas es" 

definition ka_locals :: "'addr locals  'addr set"
where "ka_locals xs = {a. Addr a  ran xs}"

lemma ka_Val_subset_ka_locals:
  "xs V = v  ka_Val v  ka_locals xs"
by(cases v)(auto simp add: ka_locals_def ran_def)

lemma ka_locals_update_subset: 
  "ka_locals (xs(V := None))  ka_locals xs"
  "ka_locals (xs(V  v))  ka_Val v  ka_locals xs"
by(auto simp add: ka_locals_def ran_def)

lemma ka_locals_empty [simp]: "ka_locals Map.empty = {}"
by(simp add: ka_locals_def)

lemma kas_append [simp]: "kas (es @ es') = kas es  kas es'"
by(induct es) auto

lemma kas_map_Val [simp]: "kas (map Val vs) = (ka_Val ` set vs)"
by(induct vs) auto

lemma ka_blocks:
  " length pns = length Ts; length vs = length Ts  
   ka (blocks pns Ts vs body) = (ka_Val ` set vs)  ka body"
by(induct pns Ts vs body rule: blocks.induct)(auto)

lemma WT_ka: "P,E  e :: T  ka e = {}"
  and WTs_kas: "P,E  es [::] Ts  kas es = {}"
by(induct rule: WT_WTs.inducts)(auto simp add: typeof_ka)

context J_heap_base begin

primrec J_known_addrs :: "'thread_id  'addr expr × 'addr locals  'addr set"
where "J_known_addrs t (e, xs) = insert (thread_id2addr t) (ka e  ka_locals xs  set start_addrs)"

lemma assumes wf: "wf_J_prog P" 
  and ok: "start_heap_ok"
  shows red_known_addrs_mono:
  "P,t  e, s -ta e', s'  J_known_addrs t (e', lcl s')  J_known_addrs t (e, lcl s)  new_obs_addrs tao"
  and reds_known_addrs_mono:
  "P,t  es, s [-ta→] es', s'  kas es'  ka_locals (lcl s')  insert (thread_id2addr t) (kas es  ka_locals (lcl s))  new_obs_addrs tao  set start_addrs"
proof(induct rule: red_reds.inducts)
  case RedVar thus ?case by(auto dest: ka_Val_subset_ka_locals)
next
  case RedLAss thus ?case by(auto simp add: ka_locals_def ran_def)
next
  case RedBinOp thus ?case by(auto dest: binop_known_addrs[OF ok])
next
  case RedBinOpFail thus ?case by(auto dest: binop_known_addrs[OF ok])
next
  case RedCall thus ?case
    by(auto simp add: ka_blocks new_obs_addrs_def wf_mdecl_def dest!: sees_wf_mdecl[OF wf] WT_ka)
next
  case (RedCallExternal s a T M Ts T D vs ta va h') thus ?case
    by(cases va)(auto dest!: red_external_known_addrs_mono[OF ok])
next
  case (BlockRed e h l V vo ta e' h' l')
  thus ?case using ka_locals_update_subset[where xs = l and V=V] ka_locals_update_subset[where xs = l' and V=V]
    apply(cases "l V")
    apply(auto simp del: fun_upd_apply del: subsetI)
    apply(blast dest: ka_Val_subset_ka_locals)+
    done
qed(simp_all add: new_obs_addrs_def addr_of_sys_xcpt_start_addr[OF ok] subset_Un1 subset_Un2 subset_insert ka_Val_subset_new_obs_Addr_ReadMem ka_blocks del: fun_upd_apply, blast+)

lemma red_known_addrs_ReadMem:
  " P,t  e, s -ta e', s'; ReadMem ad al v  set tao   ad  J_known_addrs t (e, lcl s)"
  and reds_known_addrss_ReadMem:
  " P,t  es, s [-ta→] es', s'; ReadMem ad al v  set tao 
   ad  insert (thread_id2addr t) (kas es  ka_locals (lcl s))  set start_addrs"
proof(induct rule: red_reds.inducts)
  case RedCallExternal thus ?case by simp (blast dest: red_external_known_addrs_ReadMem)
next
  case (BlockRed e h l V vo ta e' h' l')
  thus ?case using ka_locals_update_subset[where xs = l and V=V] ka_locals_update_subset[where xs = l' and V=V]
    by(auto simp del: fun_upd_apply)
qed(simp_all, blast+)

lemma red_known_addrs_WriteMem:
  " P,t  e, s -ta e', s'; tao ! n = WriteMem ad al (Addr a); n < length tao 
   a  J_known_addrs t (e, lcl s)  a  new_obs_addrs (take n tao)"
  and reds_known_addrss_WriteMem:
  " P,t  es, s [-ta→] es', s'; tao ! n = WriteMem ad al (Addr a); n < length tao 
   a  insert (thread_id2addr t) (kas es  ka_locals (lcl s))  set start_addrs  new_obs_addrs (take n tao)"
proof(induct rule: red_reds.inducts)
  case RedCASSucceed thus ?case by(auto simp add: nth_Cons split: nat.split_asm)
next
  case RedCallExternal thus ?case by simp (blast dest: red_external_known_addrs_WriteMem)
next                                                            
  case (BlockRed e h l V vo ta e' h' l')
  thus ?case using ka_locals_update_subset[where xs = l and V=V] ka_locals_update_subset[where xs = l' and V=V]
    by(auto simp del: fun_upd_apply)
qed(simp_all, blast+)

end

context J_heap begin

lemma
  assumes wf: "wf_J_prog P" 
  and ok: "start_heap_ok"
  shows red_known_addrs_new_thread:
  " P,t  e, s -ta e', s'; NewThread t' x' h'  set tat 
   J_known_addrs t' x'  J_known_addrs t (e, lcl s)"
  and reds_known_addrss_new_thread:
  " P,t  es, s [-ta→] es', s'; NewThread t' x' h'  set tat 
   J_known_addrs t' x'  insert (thread_id2addr t) (kas es  ka_locals (lcl s)  set start_addrs)"
proof(induct rule: red_reds.inducts)
  case RedCallExternal thus ?case
    apply clarsimp
    apply(frule (1) red_external_new_thread_sub_thread)
    apply(frule (1) red_external_NewThread_idD)
    apply clarsimp
    
    apply(drule (1) addr2thread_id_inverse)
    apply simp
    apply(drule sub_Thread_sees_run[OF wf])
    apply clarsimp
    apply(auto 4 4 dest: sees_wf_mdecl[OF wf] WT_ka simp add: wf_mdecl_def)
    done
next
  case (BlockRed e h l V vo ta e' h' l')
  thus ?case using ka_locals_update_subset[where xs = l and V=V] ka_locals_update_subset[where xs = l' and V=V]
    by(cases "l V")(auto simp del: fun_upd_apply)
qed(simp_all, blast+)

lemma red_New_same_addr_same:
  " convert_extTA extTA,P,t  e, s -ta e', s'; 
     tao ! i = NewHeapElem a x; i < length tao;
     tao ! j = NewHeapElem a x'; j < length tao 
   i = j"
  and reds_New_same_addr_same:
  " convert_extTA extTA,P,t  es, s [-ta→] es', s'; 
     tao ! i = NewHeapElem a x; i < length tao;
     tao ! j = NewHeapElem a x'; j < length tao 
   i = j"
apply(induct rule: red_reds.inducts)
apply(auto dest: red_external_New_same_addr_same simp add: nth_Cons split: nat.split_asm)
done

end

locale J_allocated_heap = allocated_heap +
  constrains addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and P :: "'addr J_prog"

sublocale J_allocated_heap < J_heap
by(unfold_locales)

context J_allocated_heap begin

lemma red_allocated_mono: "P,t  e, s -ta e', s'  allocated (hp s)  allocated (hp s')"
  and reds_allocated_mono: "P,t  es, s [-ta→] es', s'  allocated (hp s)  allocated (hp s')"
by(induct rule: red_reds.inducts)(auto dest: allocate_allocatedD heap_write_allocated_same red_external_allocated_mono del: subsetI)

lemma red_allocatedD:
  " P,t  e, s -ta e', s'; NewHeapElem ad CTn  set tao   ad  allocated (hp s')  ad  allocated (hp s)"
  and reds_allocatedD:
  " P,t  es, s [-ta→] es', s'; NewHeapElem ad CTn  set tao   ad  allocated (hp s')  ad  allocated (hp s)"
by(induct rule: red_reds.inducts)(auto dest: allocate_allocatedD heap_write_allocated_same red_external_allocatedD)

lemma red_allocated_NewHeapElemD:
  " P,t  e, s -ta e', s'; ad  allocated (hp s'); ad  allocated (hp s)   CTn. NewHeapElem ad CTn  set tao"
  and reds_allocated_NewHeapElemD:
  " P,t  es, s [-ta→] es', s'; ad  allocated (hp s'); ad  allocated (hp s)   CTn. NewHeapElem ad CTn  set tao"
by(induct rule: red_reds.inducts)(auto dest: allocate_allocatedD heap_write_allocated_same red_external_NewHeapElemD)

lemma mred_allocated_multithreaded:
  "allocated_multithreaded addr2thread_id thread_id2addr empty_heap allocate typeof_addr heap_write allocated final_expr (mred P) P"
proof
  fix t x m ta x' m'
  assume "mred P t (x, m) ta (x', m')"
  thus "allocated m  allocated m'"
    by(auto dest: red_allocated_mono del: subsetI simp add: split_beta)
next
  fix x t m ta x' m' ad CTn
  assume "mred P t (x, m) ta (x', m')"
    and "NewHeapElem ad CTn  set tao"
  thus "ad  allocated m'  ad  allocated m"
    by(auto dest: red_allocatedD simp add: split_beta)
next
  fix t x m ta x' m' ad
  assume "mred P t (x, m) ta (x', m')"
    and "ad  allocated m'" "ad  allocated m"
  thus "CTn. NewHeapElem ad CTn  set tao"
    by(auto dest: red_allocated_NewHeapElemD simp add: split_beta)
next
  fix t x m ta x' m' i a CTn j CTn'
  assume "mred P t (x, m) ta (x', m')"
    and "tao ! i = NewHeapElem a CTn" "i < length tao"
    and "tao ! j = NewHeapElem a CTn'" "j < length tao"
  thus "i = j" by(auto dest: red_New_same_addr_same simp add: split_beta)
qed

end

sublocale J_allocated_heap < red_mthr: allocated_multithreaded 
  addr2thread_id thread_id2addr 
  spurious_wakeups
  empty_heap allocate typeof_addr heap_read heap_write allocated 
  final_expr "mred P" 
  P
by(rule mred_allocated_multithreaded)

context J_allocated_heap begin

lemma mred_known_addrs: 
  assumes wf: "wf_J_prog P"
  and ok: "start_heap_ok"
  shows "known_addrs addr2thread_id thread_id2addr empty_heap allocate typeof_addr heap_write allocated J_known_addrs final_expr (mred P) P"
proof
  fix t x m ta x' m'
  assume "mred P t (x, m) ta (x', m')"
  thus "J_known_addrs t x'  J_known_addrs t x  new_obs_addrs tao"
    by(auto del: subsetI simp add: split_beta dest: red_known_addrs_mono[OF wf ok])
next
  fix t x m ta x' m' t' x'' m''
  assume "mred P t (x, m) ta (x', m')"
    and "NewThread t' x'' m''  set tat"
  thus "J_known_addrs t' x''  J_known_addrs t x"
    by(auto del: subsetI simp add: split_beta dest: red_known_addrs_new_thread[OF wf ok])
next
  fix t x m ta x' m' ad al v
  assume "mred P t (x, m) ta (x', m')"
    and "ReadMem ad al v  set tao"
  thus "ad  J_known_addrs t x"
    by(auto simp add: split_beta dest: red_known_addrs_ReadMem)
next
  fix t x m ta x' m' n ad al ad'
  assume "mred P t (x, m) ta (x', m')"
    and "tao ! n = WriteMem ad al (Addr ad')" "n < length tao"
  thus "ad'  J_known_addrs t x  ad'  new_obs_addrs (take n tao)"
    by(auto simp add: split_beta dest: red_known_addrs_WriteMem)
qed

end


context J_heap begin

lemma red_read_typeable:
  " convert_extTA extTA,P,t  e, s -ta e', s'; P,E,hp s  e : T; ReadMem ad al v  set tao  
   T'. P,hp s  ad@al : T'"
  and reds_read_typeable:
  " convert_extTA extTA,P,t  es, s [-ta→] es', s'; P,E,hp s  es [:] Ts; ReadMem ad al v  set tao  
   T'. P,hp s  ad@al : T'"
proof(induct arbitrary: E T and E Ts rule: red_reds.inducts)
  case RedAAcc thus ?case
    by(fastforce intro: addr_loc_type.intros simp add: nat_less_iff word_sle_eq)
next
  case RedFAcc thus ?case
    by(fastforce intro: addr_loc_type.intros)
next
  case RedCASSucceed thus ?case
    by(fastforce intro: addr_loc_type.intros)
next
  case RedCASFail thus ?case
    by(fastforce intro: addr_loc_type.intros)
next
  case RedCallExternal thus ?case
    by(auto intro: red_external_read_mem_typeable)
qed auto

end

primrec new_types :: "('a, 'b, 'addr) exp  ty set"
  and new_typess :: "('a, 'b, 'addr) exp list  ty set"
where 
  "new_types (new C) = {Class C}"
| "new_types (newA Te) = insert (T⌊⌉) (new_types e)"
| "new_types (Cast T e) = new_types e"
| "new_types (e instanceof T) = new_types e"
| "new_types (Val v) = {}"
| "new_types (Var V) = {}"
| "new_types (e1 «bop» e2) = new_types e1  new_types e2"
| "new_types (V := e) = new_types e"
| "new_types (ae) = new_types a  new_types e"
| "new_types (ae := e') = new_types a  new_types e  new_types e'"
| "new_types (a∙length) = new_types a"
| "new_types (eF{D}) = new_types e"
| "new_types (eF{D} := e') = new_types e  new_types e'"
| "new_types (e∙compareAndSwap(DF, e', e'')) = new_types e  new_types e'  new_types e''"
| "new_types (eM(es)) = new_types e  new_typess es"
| "new_types {V:T=vo; e} = new_types e"
| "new_types (Synchronized x e e') = new_types e  new_types e'"
| "new_types (InSynchronized x a e) = new_types e"
| "new_types (e;; e') = new_types e  new_types e'"
| "new_types (if (e) e1 else e2) = new_types e  new_types e1  new_types e2"
| "new_types (while (b) e) = new_types b  new_types e"
| "new_types (throw e) = new_types e"
| "new_types (try e catch(C V) e') = new_types e  new_types e'"

| "new_typess [] = {}"
| "new_typess (e # es) = new_types e  new_typess es"

lemma new_types_blocks:
  " length pns = length Ts; length vs = length Ts   new_types (blocks pns vs Ts e) = new_types e"
apply(induct rule: blocks.induct)
apply(simp_all)
done

context J_heap_base begin

lemma WTrt_new_types_types: "P,E,h  e : T  new_types e  types P"
  and WTrts_new_typess_types: "P,E,h  es [:] Ts  new_typess es  types P"
by(induct rule: WTrt_WTrts.inducts) simp_all

end

lemma WT_new_types_types: "P,E  e :: T  new_types e  types P"
  and WTs_new_typess_types: "P,E  es [::] Ts  new_typess es  types P"
by(induct rule: WT_WTs.inducts) simp_all

context J_heap_conf begin

lemma red_New_typeof_addrD:
  " convert_extTA extTA,P,t  e, s -ta e', s'; new_types e  types P; hconf (hp s); NewHeapElem a x  set tao 
   typeof_addr (hp s') a = Some x"
  and reds_New_typeof_addrD:
  " convert_extTA extTA,P,t  es, s [-ta→] es', s'; new_typess es  types P; hconf (hp s); NewHeapElem a x  set tao 
   typeof_addr (hp s') a = Some x"
apply(induct rule: red_reds.inducts)
apply(auto dest: allocate_SomeD red_external_New_typeof_addrD)
done

lemma J_conf_read_heap_read_typed:
  "J_conf_read addr2thread_id thread_id2addr empty_heap allocate typeof_addr (heap_read_typed P) heap_write hconf P"
proof -
  interpret conf: heap_conf_read
    addr2thread_id thread_id2addr 
    spurious_wakeups
    empty_heap allocate typeof_addr "heap_read_typed P" heap_write hconf 
    P
    by(rule heap_conf_read_heap_read_typed)
  show ?thesis by(unfold_locales)
qed

lemma red_non_speculative_vs_conf:
  " convert_extTA extTA,P,t  e, s -ta e', s'; P,E,hp s  e : T;
    non_speculative P vs (llist_of (take n (map NormalAction tao))); vs_conf P (hp s) vs; hconf (hp s) 
   vs_conf P (hp s') (w_values P vs (take n (map NormalAction tao)))"
  and reds_non_speculative_vs_conf:
  " convert_extTA extTA,P,t  es, s [-ta→] es', s'; P,E,hp s  es [:] Ts;
    non_speculative P vs (llist_of (take n (map NormalAction tao))); vs_conf P (hp s) vs; hconf (hp s) 
   vs_conf P (hp s') (w_values P vs (take n (map NormalAction tao)))"
proof(induct arbitrary: E T and E Ts rule: red_reds.inducts)
  case (RedAAss h a U n i w V h' xs)
  from ‹sint i < int n 0 <=s i have "nat (sint i) < n"
    by (simp add: word_sle_eq nat_less_iff)
  with typeof_addr h a = Array_type U n have "P,h  a@ACell (nat (sint i)) : U"
    by(auto intro: addr_loc_type.intros)
  moreover from heap_write h a (ACell (nat (sint i))) w h' have "h  h'" by(rule hext_heap_write)
  ultimately have "P,h'  a@ACell (nat (sint i)) : U" by(rule addr_loc_type_hext_mono)
  moreover from ‹typeofh w = V P  V  U have "P,h  w :≤ U" by(simp add: conf_def)
  with h  h' have "P,h'  w :≤ U" by(rule conf_hext)
  ultimately have "T. P,h'  a@ACell (nat (sint i)) : T  P,h'  w :≤ T" by blast 
  thus ?case using RedAAss
    by(auto intro!: vs_confI split: if_split_asm dest: vs_confD simp add: take_Cons')(blast dest: vs_confD hext_heap_write intro: addr_loc_type_hext_mono conf_hext)+
next
  case (RedFAss h e D F v h' xs)
  hence "T. P,h'  e@CField D F : T  P,h'  v :≤ T"
    by(force dest!: hext_heap_write intro!: addr_loc_type.intros intro: typeof_addr_hext_mono type_of_hext_type_of simp add: conf_def)
  thus ?case using RedFAss
    by(auto intro!: vs_confI simp add: take_Cons' split: if_split_asm dest: vs_confD)(blast dest: vs_confD hext_heap_write intro: addr_loc_type_hext_mono conf_hext)+
next
  case (RedCASSucceed h a D F v v' h' l)
  hence "T. P,h'  a@CField D F : T  P,h'  v' :≤ T"
    by(force dest!: hext_heap_write intro!: addr_loc_type.intros intro: typeof_addr_hext_mono type_of_hext_type_of simp add: conf_def take_Cons')
  thus ?case using RedCASSucceed
    by(auto simp add: take_Cons' split: if_split_asm dest: vs_confD intro!: vs_confI)
      (blast dest: vs_confD hext_heap_write intro: addr_loc_type_hext_mono conf_hext)+
next
  case RedCallExternal thus ?case by(auto intro: red_external_non_speculative_vs_conf)
qed(auto dest: vs_conf_allocate hext_allocate intro: vs_conf_hext simp add: take_Cons')

lemma red_non_speculative_typeable:
  " convert_extTA extTA,P,t  e, s -ta e', s'; P,E,hp s  e : T;
    non_speculative P vs (llist_of (map NormalAction tao)); vs_conf P (hp s) vs; hconf (hp s) 
   J_heap_base.red addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr (heap_read_typed P) heap_write (convert_extTA extTA) P t e s ta e' s'"
  and reds_non_speculative_typeable:
  " convert_extTA extTA,P,t  es, s [-ta→] es', s'; P,E,hp s  es [:] Ts;
    non_speculative P vs (llist_of (map NormalAction tao)); vs_conf P (hp s) vs; hconf (hp s) 
   J_heap_base.reds addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr (heap_read_typed P) heap_write (convert_extTA extTA) P t es s ta es' s'"
proof(induct arbitrary: E T and E Ts rule: red_reds.inducts)
  case RedCall thus ?case by(blast intro: J_heap_base.red_reds.RedCall)
next
  case RedCallExternal thus ?case
    by(auto intro: J_heap_base.red_reds.RedCallExternal red_external_non_speculative_typeable)
qed(auto intro: J_heap_base.red_reds.intros intro!: heap_read_typedI dest: vs_confD addr_loc_type_fun)

end

sublocale J_heap_base < red_mthr: 
  if_multithreaded
    final_expr
    "mred P"
    convert_RA
  for P
by(unfold_locales)


locale J_allocated_heap_conf = 
  J_heap_conf 
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write hconf
    P
  +
  J_allocated_heap 
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write
    allocated
    P
  for addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and hconf :: "'heap  bool"
  and allocated :: "'heap  'addr set"
  and P :: "'addr J_prog"
begin

lemma mred_known_addrs_typing:
  assumes wf: "wf_J_prog P"
  and ok: "start_heap_ok"
  shows "known_addrs_typing addr2thread_id thread_id2addr empty_heap allocate typeof_addr heap_write allocated J_known_addrs final_expr (mred P) (λt x h. ET. sconf_type_ok ET t x h) P"
proof -
  interpret known_addrs
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write 
    allocated J_known_addrs
    final_expr "mred P" P
    using wf ok by(rule mred_known_addrs)
  
  show ?thesis
  proof
    fix t x m ta x' m'
    assume "mred P t (x, m) ta (x', m')"
    thus "m  m'" by(auto dest: red_hext_incr simp add: split_beta)
  next
    fix t x m ta x' m' vs
    assume red: "mred P t (x, m) ta (x', m')"
      and ts_ok: "ET. sconf_type_ok ET t x m"
      and vs: "vs_conf P m vs"
      and ns: "non_speculative P vs (llist_of (map NormalAction tao))"
    
    let ?mred = "J_heap_base.mred addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr (heap_read_typed P) heap_write P"

    have lift: "lifting_inv final_expr ?mred sconf_type_ok"
      by(intro J_conf_read.lifting_inv_sconf_subject_ok J_conf_read_heap_read_typed wf)
    moreover
    from ts_ok obtain ET where type: "sconf_type_ok ET t x m" ..
    with red vs ns have red': "?mred t (x, m) ta (x', m')"
      by(auto simp add: split_beta sconf_type_ok_def sconf_def type_ok_def dest: red_non_speculative_typeable)
    ultimately have "sconf_type_ok ET t x' m'" using type
      by(rule lifting_inv.invariant_red[where r="?mred"])
    thus "ET. sconf_type_ok ET t x' m'" ..
    { fix t'' x'' m''
      assume New: "NewThread t'' x'' m''  set tat"
      with red have "m'' = snd (x', m')" by(rule red_mthr.new_thread_memory)
      with lift red' type New
      show "ET. sconf_type_ok ET t'' x'' m''"
        by-(rule lifting_inv.invariant_NewThread[where r="?mred"], simp_all) }
    { fix t'' x''
      assume "ET. sconf_type_ok ET t'' x'' m"
      with lifting_inv.invariant_other[where r="?mred", OF lift red' type]
      show "ET. sconf_type_ok ET t'' x'' m'" by blast }
  next
    fix t x m ta x' m' vs n
    assume red: "mred P t (x, m) ta (x', m')"
      and ts_ok: "ET. sconf_type_ok ET t x m"
      and vs: "vs_conf P m vs"
      and ns: "non_speculative P vs (llist_of (take n (map NormalAction tao)))"
    thus "vs_conf P m' (w_values P vs (take n (map NormalAction tao)))"
      by(cases x)(auto dest: red_non_speculative_vs_conf simp add: sconf_type_ok_def type_ok_def sconf_def)
  next
    fix t x m ta x' m' ad al v
    assume "mred P t (x, m) ta (x', m')"
      and "ET. sconf_type_ok ET t x m"
      and "ReadMem ad al v  set tao"
    thus "T. P,m  ad@al : T"
      by(fastforce simp add: sconf_type_ok_def type_ok_def sconf_def split_beta dest: red_read_typeable)
  next
    fix t x m ta x' m' ad hT
    assume "mred P t (x, m) ta (x', m')"
      and "ET. sconf_type_ok ET t x m"
      and "NewHeapElem ad hT  set tao"
    thus "typeof_addr m' ad = hT"
      by(auto dest: red_New_typeof_addrD[where x="hT"] dest!: WTrt_new_types_types simp add: split_beta sconf_type_ok_def sconf_def type_ok_def)
  qed
qed

end

context J_allocated_heap_conf begin

lemma executions_sc:
  assumes wf: "wf_J_prog P"
  and wf_start: "wf_start_state P C M vs"
  and vs2: "(ka_Val ` set vs)  set start_addrs"
  shows "executions_sc_hb (J_ℰ P C M vs status) P"
  (is "executions_sc_hb ?E P")
proof -
  from wf_start obtain Ts T pns body D where ok: "start_heap_ok"
    and sees: "P  C sees M:TsT=(pns, body) in D"
    and vs1: "P,start_heap  vs [:≤] Ts" by cases auto
  
  interpret known_addrs_typing
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write 
    allocated J_known_addrs
    final_expr "mred P" "λt x h. ET. sconf_type_ok ET t x h" P
    using wf ok by(rule mred_known_addrs_typing)
  
  from wf_prog_wf_syscls[OF wf] J_start_state_sconf_type_ok[OF wf wf_start]
  show ?thesis
  proof(rule executions_sc_hb)
    from wf sees have "wf_mdecl wf_J_mdecl P D (M, Ts, T, (pns, body))" by(rule sees_wf_mdecl)
    then obtain T' where len1: "length pns = length Ts" and wt: "P,[thisClass D,pns [↦] Ts]  body :: T'"
      by(auto simp add: wf_mdecl_def)
    from vs1 have len2: "length vs = length Ts" by(rule list_all2_lengthD)
    show "J_known_addrs start_tid ((λ(pns, body) vs. (blocks (this # pns) (Class (fst (method P C M)) # fst (snd (method P C M))) (Null # vs) body, Map.empty)) (the (snd (snd (snd (method P C M))))) vs)  allocated start_heap"
      using sees vs2 len1 len2 WT_ka[OF wt]
      by(auto simp add: split_beta start_addrs_allocated ka_blocks intro: start_tid_start_addrs[OF wf_prog_wf_syscls[OF wf] ok])
  qed
qed

end

declare split_paired_Ex [simp del]

context J_progress begin

lemma ex_WTrt_simps:
  "P,E,h  e : T  E T. P,E,h  e : T"
by blast

abbreviation (input) J_non_speculative_read_bound :: nat
  where "J_non_speculative_read_bound  2"

lemma assumes hrt: "heap_read_typeable hconf P"
  and vs: "vs_conf P (shr s) vs"
  and hconf: "hconf (shr s)"
  shows red_non_speculative_read:
  " P,t  e, (shr s, xs) -ta e', (h', xs'); E T. P,E,shr s  e : T;
    red_mthr.mthr.if.actions_ok s t ta; 
    I < length tao; tao ! I = ReadMem a'' al'' v; v'  w_values P vs (map NormalAction (take I tao)) (a'', al'');
    non_speculative P vs (llist_of (map NormalAction (take I tao))) 
   ta' e'' xs'' h''. P,t  e, (shr s, xs) -ta' e'', (h'', xs'')  
           red_mthr.mthr.if.actions_ok s t ta'  
           I < length ta'o  take I ta'o = take I tao  
           ta'o ! I = ReadMem a'' al'' v'  length ta'o  max J_non_speculative_read_bound (length tao)"
  and reds_non_speculative_read:
  " P,t  es, (shr s, xs) [-ta→] es', (h', xs'); E Ts. P,E,shr s  es [:] Ts;
     red_mthr.mthr.if.actions_ok s t ta;
    I < length tao; tao ! I = ReadMem a'' al'' v; v'  w_values P vs (map NormalAction (take I tao)) (a'', al'');
    non_speculative P vs (llist_of (map NormalAction (take I tao))) 
   ta' es'' xs'' h''. P,t  es, (shr s, xs) [-ta'→] es'', (h'', xs'')  
           red_mthr.mthr.if.actions_ok s t ta'  
           I < length ta'o  take I ta'o = take I tao  
           ta'o ! I = ReadMem a'' al'' v'  length ta'o  max J_non_speculative_read_bound (length tao)"
proof(induct e hxs"(shr s, xs)" ta e' hxs'"(h', xs')" 
        and es hxs"(shr s, xs)" ta es' hxs'"(h', xs')"
      arbitrary: xs xs' and xs xs' rule: red_reds.inducts)
  case (RedAAcc a U n i v e)
  hence [simp]: "I = 0" "al'' = ACell (nat (sint i))" "a'' = a" 
    and v': "v'  vs (a, ACell (nat (sint i)))" by simp_all
  from RedAAcc have adal: "P,shr s  a@ACell (nat (sint i)) : U"
    by(auto intro: addr_loc_type.intros simp add: nat_less_iff word_sle_eq)
  from v' vs adal have "P,shr s  v' :≤ U" by(auto dest!: vs_confD dest: addr_loc_type_fun)  
  with hrt adal have "heap_read (shr s) a (ACell (nat (sint i))) v'" using hconf by(rule heap_read_typeableD)
  with typeof_addr (shr s) a = Array_type U n 0 <=s i ‹sint i < int n 
    ‹red_mthr.mthr.if.actions_ok s t ReadMem a (ACell (nat (sint i))) v
  show ?case by(fastforce intro: red_reds.RedAAcc)
next
  case (RedFAcc a D F v)
  hence [simp]: "I = 0" "al'' = CField D F" "a'' = a"
    and v': "v'  vs (a, CField D F)" by simp_all
  from RedFAcc obtain E T where "P,E,shr s  addr aF{D} : T" by blast
  with RedFAcc have adal: "P,shr s  a@CField D F : T" by(auto 4 4 intro: addr_loc_type.intros)
  from v' vs adal have "P,shr s  v' :≤ T" by(auto dest!: vs_confD dest: addr_loc_type_fun)  
  with hrt adal have "heap_read (shr s) a (CField D F) v'" using hconf by(rule heap_read_typeableD)
  with ‹red_mthr.mthr.if.actions_ok s t ReadMem a (CField D F) v
  show ?case by(fastforce intro: red_reds.RedFAcc)
next
  case (RedCASSucceed a D F v'' v''')
  hence [simp]: "I = 0" "al'' = CField D F" "a'' = a" "v'' = v" 
    and v': "v'  vs (a, CField D F)" by(auto simp add: take_Cons' split: if_split_asm)
  from RedCASSucceed.prems(1) obtain E T where
    "P,E,shr s  addr a∙compareAndSwap(DF, Val v'', Val v''') : T" by clarify
  then obtain T where adal: "P,shr s  a@CField D F : T" 
    and v'': "P,shr s  v'' :≤ T" and v''': "P,shr s  v''' :≤ T"
    by(fastforce intro: addr_loc_type.intros simp add: conf_def)
  from v' vs adal have "P,shr s  v' :≤ T" by(auto dest!: vs_confD dest: addr_loc_type_fun)  
  from hrt adal this hconf have read: "heap_read (shr s) a (CField D F) v'" by(rule heap_read_typeableD)
  show ?case
  proof(cases "v' = v''")
    case True
    then show ?thesis using RedCASSucceed 
      by(fastforce intro: red_reds.RedCASSucceed)
  next
    case False
    then show ?thesis using read RedCASSucceed
      by(fastforce intro: RedCASFail)
  qed
next
  case (RedCASFail a D F v'' v''' v'''')
  hence [simp]: "I = 0" "al'' = CField D F" "a'' = a" "v'' = v" 
    and v': "v'  vs (a, CField D F)" by(auto simp add: take_Cons' split: if_split_asm)
  from RedCASFail.prems(1) obtain E T where
    "P,E,shr s  addr a∙compareAndSwap(DF, Val v''', Val v'''') : T" by(iprover)
  then obtain T where adal: "P,shr s  a@CField D F : T" 
    and v''': "P,shr s  v''' :≤ T" and v'''': "P,shr s  v'''' :≤ T"
    by(fastforce intro: addr_loc_type.intros simp add: conf_def)
  from v' vs adal have "P,shr s  v' :≤ T" by(auto dest!: vs_confD dest: addr_loc_type_fun)  
  from hrt adal this hconf have read: "heap_read (shr s) a (CField D F) v'" by(rule heap_read_typeableD)
  show ?case
  proof(cases "v' = v'''")
    case True
    from heap_write_total[OF hconf adal v''''] obtain h' where
      "heap_write (shr s) a (CField D F) v'''' h'" ..
    with read RedCASFail True show ?thesis 
      by(fastforce intro: RedCASSucceed)
  next
    case False
    with read RedCASFail show ?thesis by(fastforce intro: red_reds.RedCASFail)
  qed
next
  case (RedCallExternal a U M Ts Tr D ps ta' va h' ta e')
  from P,t  aM(ps),hp (shr s, xs) -ta'→ext va,h'
  have red: "P,t  aM(ps),shr s -ta'→ext va,h'" by simp
  from RedCallExternal have aok: "red_mthr.mthr.if.actions_ok s t ta'" by simp
  from RedCallExternal have "I < length ta'o"
    and "ta'o ! I = ReadMem a'' al'' v"
    and "v'  w_values P vs (map NormalAction (take I ta'o)) (a'', al'')"
    and "non_speculative P vs (llist_of (map NormalAction (take I ta'o)))" by simp_all
  from red_external_non_speculative_read[OF hrt vs red aok hconf this]
    typeof_addr (hp (shr s, xs)) a = U 
    P  class_type_of U sees M: TsTr = Native in D ta = extTA2J P ta'
    I < length tao
  show ?case by(fastforce intro: red_reds.RedCallExternal)
next
  case NewArrayRed thus ?case by(clarsimp simp add: split_paired_Ex ex_WTrt_simps)(blast intro: red_reds.NewArrayRed)
next 
  case CastRed thus ?case
    by(clarsimp simp add: split_paired_Ex ex_WTrt_simps)(blast intro: red_reds.CastRed)
next
  case InstanceOfRed thus ?case
    by(clarsimp simp add: split_paired_Ex ex_WTrt_simps)(blast intro: red_reds.InstanceOfRed)
next
  case BinOpRed1 thus ?case
    by(clarsimp simp add: split_paired_Ex ex_WTrt_simps)(blast intro: red_reds.BinOpRed1)
next
  case BinOpRed2 thus ?case
    by(clarsimp simp add: split_paired_Ex ex_WTrt_simps)(blast intro: red_reds.BinOpRed2)
next
  case LAssRed thus ?case
    by(clarsimp simp add: split_paired_Ex ex_WTrt_simps)(blast intro: red_reds.LAssRed)
next
  case AAccRed1 thus ?case
    by(clarsimp simp add: split_paired_Ex ex_WTrt_simps)(blast intro: red_reds.AAccRed1)
next
  case AAccRed2 thus ?case
    by(clarsimp simp add: split_paired_Ex ex_WTrt_simps)(blast intro: red_reds.AAccRed2)
next
  case AAssRed1 thus ?case
    by(clarsimp simp add: split_paired_Ex ex_WTrt_simps)(blast intro: red_reds.AAssRed1)
next
  case AAssRed2 thus ?case
    by(clarsimp simp add: split_paired_Ex ex_WTrt_simps)(blast intro: red_reds.AAssRed2)
next
  case AAssRed3 thus ?case
    by(clarsimp simp add: split_paired_Ex ex_WTrt_simps)(blast intro: red_reds.AAssRed3)+
next
  case ALengthRed thus ?case
    by(clarsimp simp add: split_paired_Ex ex_WTrt_simps)(blast intro: red_reds.ALengthRed)
next
  case FAccRed thus ?case
    by(clarsimp simp add: split_paired_Ex ex_WTrt_simps)(blast intro: red_reds.FAccRed)
next
  case FAssRed1 thus ?case
    by(clarsimp simp add: split_paired_Ex ex_WTrt_simps)(blast intro: red_reds.FAssRed1)
next
  case FAssRed2 thus ?case
    by(clarsimp simp add: split_paired_Ex ex_WTrt_simps)(blast intro: red_reds.FAssRed2)
next
  case CASRed1 thus ?case
    by(clarsimp simp add: split_paired_Ex ex_WTrt_simps)(blast intro: red_reds.CASRed1)
next
  case CASRed2 thus ?case
    by(clarsimp simp add: split_paired_Ex ex_WTrt_simps)(blast intro: red_reds.CASRed2)
next
  case CASRed3 thus ?case
    by(clarsimp simp add: split_paired_Ex ex_WTrt_simps)(blast intro: red_reds.CASRed3)
next
  case CallObj thus ?case
    by(clarsimp simp add: split_paired_Ex ex_WTrt_simps)(blast intro: red_reds.CallObj)
next
  case CallParams thus ?case
    by(clarsimp simp add: split_paired_Ex ex_WTrt_simps)(blast intro: red_reds.CallParams)
next
  case BlockRed thus ?case
    by(clarsimp simp add: split_paired_Ex ex_WTrt_simps)(fastforce intro: red_reds.BlockRed)+
next
  case SynchronizedRed1 thus ?case
    by(clarsimp simp add: split_paired_Ex ex_WTrt_simps)(blast intro: red_reds.SynchronizedRed1)
next
  case SynchronizedRed2 thus ?case
    by(clarsimp simp add: split_paired_Ex ex_WTrt_simps)(blast intro: red_reds.SynchronizedRed2)
next
  case SeqRed thus ?case
    by(clarsimp simp add: split_paired_Ex ex_WTrt_simps)(blast intro: red_reds.SeqRed)
next
  case CondRed thus ?case
    by(clarsimp simp add: split_paired_Ex ex_WTrt_simps)(blast intro: red_reds.CondRed)
next
  case ThrowRed thus ?case
    by(clarsimp simp add: split_paired_Ex ex_WTrt_simps)(blast intro: red_reds.ThrowRed)
next
  case TryRed thus ?case
    by(clarsimp simp add: split_paired_Ex ex_WTrt_simps)(blast intro: red_reds.TryRed)
next
  case ListRed1 thus ?case
    by(clarsimp simp add: split_paired_Ex ex_WTrt_simps)(blast intro: red_reds.ListRed1)
next
  case ListRed2 thus ?case
    by(clarsimp simp add: split_paired_Ex ex_WTrt_simps)(blast intro: red_reds.ListRed2)
qed(simp_all)

end


sublocale J_allocated_heap_conf < if_known_addrs_base
  J_known_addrs
  final_expr "mred P" convert_RA 
.


declare split_paired_Ex [simp]
declare eq_upto_seq_inconsist_simps [simp del]

locale J_allocated_progress = 
  J_progress
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write hconf
    P
  +
  J_allocated_heap_conf
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write hconf
    allocated
    P
  for addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and hconf :: "'heap  bool"
  and allocated :: "'heap  'addr set"
  and P :: "'addr J_prog"
begin

lemma non_speculative_read:
  assumes wf: "wf_J_prog P"
  and hrt: "heap_read_typeable hconf P"
  and wf_start: "wf_start_state P C M vs"
  and ka: "(ka_Val ` set vs)  set start_addrs"
  shows "red_mthr.if.non_speculative_read J_non_speculative_read_bound
      (init_fin_lift_state status (J_start_state P C M vs)) 
      (w_values P (λ_. {}) (map snd (lift_start_obs start_tid start_heap_obs)))"
  (is "red_mthr.if.non_speculative_read _ ?start_state ?start_vs")
proof(rule red_mthr.if.non_speculative_readI)
  fix ttas s' t x ta x' m' i ad al v v'
  assume τRed: "red_mthr.mthr.if.RedT P ?start_state ttas s'"
    and sc: "non_speculative P ?start_vs (llist_of (concat (map (λ(t, ta). tao) ttas)))"
    and ts't: "thr s' t = (x, no_wait_locks)"
    and red: "red_mthr.init_fin P t (x, shr s') ta (x', m')"
    and aok: "red_mthr.mthr.if.actions_ok s' t ta"
    and i: "i < length tao"
    and ns': "non_speculative P (w_values P ?start_vs (concat (map (λ(t, ta). tao) ttas))) (llist_of (take i tao))"
    and read: "tao ! i = NormalAction (ReadMem ad al v)"
    and v': "v'  w_values P ?start_vs (concat (map (λ(t, ta). tao) ttas) @ take i tao) (ad, al)" 

  from wf_start obtain Ts T pns body D where ok: "start_heap_ok"
    and sees: "P  C sees M:TsT = (pns, body) in D"
    and conf: "P,start_heap  vs [:≤] Ts" by cases auto

  let ?conv = "λttas. concat (map (λ(t, ta). tao) ttas)"
  let ?vs' = "w_values P ?start_vs (?conv ttas)"
  let ?wt_ok = "init_fin_lift_inv sconf_type_ok"
  let ?ET_start = "J_sconf_type_ET_start P C M"
  let ?start_obs = "map snd (lift_start_obs start_tid start_heap_obs)"
  let ?start_state = "init_fin_lift_state status (J_start_state P C M vs)"

  interpret known_addrs_typing
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write 
    allocated J_known_addrs
    final_expr "mred P" "λt x h. ET. sconf_type_ok ET t x h" P
    using wf ok by(rule mred_known_addrs_typing)

  from wf sees have "wf_mdecl wf_J_mdecl P D (M, Ts, T, (pns, body))" by(rule sees_wf_mdecl)
  then obtain T' where len1: "length pns = length Ts" and wt: "P,[thisClass D,pns [↦] Ts]  body :: T'"
    by(auto simp add: wf_mdecl_def)
  from conf have len2: "length vs = length Ts" by(rule list_all2_lengthD)

  from wf wf_start have ts_ok_start: "ts_ok (init_fin_lift (λt x h. ET. sconf_type_ok ET t x h)) (thr ?start_state) (shr ?start_state)"
    unfolding ts_ok_init_fin_lift_init_fin_lift_state shr_start_state by(rule J_start_state_sconf_type_ok)
  have sc': "non_speculative P ?start_vs (lmap snd (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) (llist_of ttas))))"
    using sc by(simp add: lmap_lconcat llist.map_comp o_def split_def lconcat_llist_of[symmetric])

  from start_state_vs_conf[OF wf_prog_wf_syscls[OF wf]]
  have vs_conf_start: "vs_conf P (shr ?start_state) ?start_vs"
    by(simp add:init_fin_lift_state_conv_simps start_state_def split_beta)
  with τRed ts_ok_start sc
  have wt': "ts_ok (init_fin_lift (λt x h. ET. sconf_type_ok ET t x h)) (thr s') (shr s')"
    and vs': "vs_conf P (shr s') ?vs'" by(rule if_RedT_non_speculative_invar)+

  from red i read obtain e xs e' xs' ta'
    where x: "x = (Running, e, xs)" and x': "x' = (Running, e', xs')"
    and ta: "ta = convert_TA_initial (convert_obs_initial ta')"
    and red': "P,t  e, (shr s', xs) -ta' e', (m', xs')"
    by cases fastforce+
  
  from ts't wt' x obtain E T where wte: "P,E,shr s'  e : T"
    and hconf: "hconf (shr s')"
    by(auto dest!: ts_okD simp add: sconf_type_ok_def sconf_def type_ok_def)

  have aok': "red_mthr.mthr.if.actions_ok s' t ta'" using aok unfolding ta by simp

  from i read v' ta ns' have "i < length ta'o" and "ta'o ! i = ReadMem ad al v" 
    and "v'  w_values P ?vs' (map NormalAction (take i ta'o)) (ad, al)"
    and "non_speculative P ?vs' (llist_of (map NormalAction (take i ta'o)))"
    by(simp_all add: take_map)

  from red_non_speculative_read[OF hrt vs' hconf red' _ aok' this] wte
  obtain ta'' e'' xs'' h''
    where red'': "P,t  e, (shr s', xs) -ta'' e'', (h'', xs'')"
    and aok'': "red_mthr.mthr.if.actions_ok s' t ta''"
    and i'': "i < length ta''o"
    and eq'': "take i ta''o = take i ta'o"
    and read'': "ta''o ! i = ReadMem ad al v'"
    and len'': "length ta''o  max J_non_speculative_read_bound (length ta'o)" by blast

  let ?x' = "(Running, e'', xs'')"
  let ?ta' = "convert_TA_initial (convert_obs_initial ta'')"
  from red'' have "red_mthr.init_fin P t (x, shr s') ?ta' (?x', h'')"
    unfolding x by -(rule red_mthr.init_fin.NormalAction, simp)
  moreover from aok'' have "red_mthr.mthr.if.actions_ok s' t ?ta'" by simp
  moreover from i'' have "i < length ?ta'o" by simp
  moreover from eq'' have "take i ?ta'o = take i tao" unfolding ta by(simp add: take_map)
  moreover from read'' i'' have "?ta'o ! i = NormalAction (ReadMem ad al v')" by(simp add: nth_map)
  moreover from len'' have "length ?ta'o  max J_non_speculative_read_bound (length tao)"
    unfolding ta by simp
  ultimately
  show "ta' x'' m''. red_mthr.init_fin P t (x, shr s') ta' (x'', m'') 
                      red_mthr.mthr.if.actions_ok s' t ta' 
                      i < length ta'o  take i ta'o = take i tao 
                      ta'o ! i = NormalAction (ReadMem ad al v')  
                      length ta'o  max J_non_speculative_read_bound (length tao)"
    by blast
qed

lemma J_cut_and_update:
  assumes wf: "wf_J_prog P"
  and hrt: "heap_read_typeable hconf P"
  and wf_start: "wf_start_state P C M vs"
  and ka: "(ka_Val ` set vs)  set start_addrs"
  shows "red_mthr.if.cut_and_update (init_fin_lift_state status (J_start_state P C M vs))
           (mrw_values P Map.empty (map snd (lift_start_obs start_tid start_heap_obs)))"
proof -
  from wf_start obtain Ts T pns body D where ok: "start_heap_ok"
    and sees: "P  C sees M: TsT = (pns, body) in D"
    and conf: "P,start_heap  vs [:≤] Ts" by cases auto

  interpret known_addrs_typing
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write 
    allocated J_known_addrs
    final_expr "mred P" "λt x h. ET. sconf_type_ok ET t x h" P
    using wf ok by(rule mred_known_addrs_typing)

  let ?start_vs = "w_values P (λ_. {}) (map snd (lift_start_obs start_tid start_heap_obs))"
  let ?wt_ok = "init_fin_lift_inv sconf_type_ok"
  let ?ET_start = "J_sconf_type_ET_start P C M"
  let ?start_obs = "map snd (lift_start_obs start_tid start_heap_obs)"
  let ?start_state = "init_fin_lift_state status (J_start_state P C M vs)"

  from wf sees have "wf_mdecl wf_J_mdecl P D (M, Ts, T, (pns, body))" by(rule sees_wf_mdecl)
  then obtain T' where len1: "length pns = length Ts" and wt: "P,[thisClass D,pns [↦] Ts]  body :: T'"
    by(auto simp add: wf_mdecl_def)
  from conf have len2: "length vs = length Ts" by(rule list_all2_lengthD)

  note wf_prog_wf_syscls[OF wf] non_speculative_read[OF wf hrt wf_start ka]
  moreover 
  from wf wf_start have ts_ok_start: "ts_ok (init_fin_lift (λt x h. ET. sconf_type_ok ET t x h)) (thr ?start_state) (shr ?start_state)"
    unfolding ts_ok_init_fin_lift_init_fin_lift_state shr_start_state by(rule J_start_state_sconf_type_ok)
  moreover
  have ka: "J_known_addrs start_tid ((λ(pns, body) vs. (blocks (this # pns) (Class (fst (method P C M)) # fst (snd (method P C M))) (Null # vs) body, Map.empty)) (the (snd (snd (snd (method P C M))))) vs)  allocated start_heap"
    using sees ka len1 len2 WT_ka[OF wt]
    by(auto simp add: split_beta start_addrs_allocated ka_blocks intro: start_tid_start_addrs[OF wf_prog_wf_syscls[OF wf] ok])
  ultimately show ?thesis by(rule non_speculative_read_into_cut_and_update)
qed

lemma J_drf:
  assumes wf: "wf_J_prog P"
  and hrt: "heap_read_typeable hconf P"
  and wf_start: "wf_start_state P C M vs"
  and ka: "(ka_Val ` set vs)  set start_addrs"
  shows "drf (J_ℰ P C M vs status) P"
proof -
  from wf_start obtain Ts T pns body D where ok: "start_heap_ok"
    and sees: "P  C sees M: TsT = (pns, body) in D"
    and conf: "P,start_heap  vs [:≤] Ts" by cases auto

  from J_cut_and_update[OF assms] wf_prog_wf_syscls[OF wf] J_start_state_sconf_type_ok[OF wf wf_start] show ?thesis
  proof(rule known_addrs_typing.drf[OF mred_known_addrs_typing[OF wf ok]])
    from wf sees have "wf_mdecl wf_J_mdecl P D (M, Ts, T, (pns, body))" by(rule sees_wf_mdecl)
    then obtain T' where len1: "length pns = length Ts" and wt: "P,[thisClass D,pns [↦] Ts]  body :: T'"
      by(auto simp add: wf_mdecl_def)
    from conf have len2: "length vs = length Ts" by(rule list_all2_lengthD)
    show "J_known_addrs start_tid ((λ(pns, body) vs. (blocks (this # pns) (Class (fst (method P C M)) # fst (snd (method P C M))) (Null # vs) body, Map.empty)) (the (snd (snd (snd (method P C M))))) vs)  allocated start_heap"
      using sees ka len1 len2 WT_ka[OF wt]
      by(auto simp add: split_beta start_addrs_allocated ka_blocks intro: start_tid_start_addrs[OF wf_prog_wf_syscls[OF wf] ok])
  qed
qed

lemma J_sc_legal:
  assumes wf: "wf_J_prog P"
  and hrt: "heap_read_typeable hconf P"
  and wf_start: "wf_start_state P C M vs"
  and ka: "(ka_Val ` set vs)  set start_addrs"
  shows "sc_legal (J_ℰ P C M vs status) P"
proof -
  from wf_start obtain Ts T pns body D where ok: "start_heap_ok"
    and sees: "P  C sees M: TsT = (pns, body) in D"
    and conf: "P,start_heap  vs [:≤] Ts" by cases auto
  interpret known_addrs_typing
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write 
    allocated J_known_addrs
    final_expr "mred P" "λt x h. ET. sconf_type_ok ET t x h" P
    using wf ok by(rule mred_known_addrs_typing)

  let ?start_vs = "w_values P (λ_. {}) (map snd (lift_start_obs start_tid start_heap_obs))"
  let ?wt_ok = "init_fin_lift_inv sconf_type_ok"
  let ?ET_start = "J_sconf_type_ET_start P C M"
  let ?start_obs = "map snd (lift_start_obs start_tid start_heap_obs)"
  let ?start_state = "init_fin_lift_state status (J_start_state P C M vs)"

  from wf sees have "wf_mdecl wf_J_mdecl P D (M, Ts, T, (pns, body))" by(rule sees_wf_mdecl)
  then obtain T' where len1: "length pns = length Ts" and wt: "P,[thisClass D,pns [↦] Ts]  body :: T'"
    by(auto simp add: wf_mdecl_def)
  from conf have len2: "length vs = length Ts" by(rule list_all2_lengthD)

  note wf_prog_wf_syscls[OF wf] non_speculative_read[OF wf hrt wf_start ka]
  moreover
  from wf wf_start have ts_ok_start: "ts_ok (init_fin_lift (λt x h. ET. sconf_type_ok ET t x h)) (thr ?start_state) (shr ?start_state)"
    unfolding ts_ok_init_fin_lift_init_fin_lift_state shr_start_state by(rule J_start_state_sconf_type_ok)
  moreover have ka_allocated: "J_known_addrs start_tid ((λ(pns, body) vs. (blocks (this # pns) (Class (fst (method P C M)) # fst (snd (method P C M))) (Null # vs) body, Map.empty)) (the (snd (snd (snd (method P C M))))) vs)  allocated start_heap"
    using sees ka len1 len2 WT_ka[OF wt]
    by(auto simp add: split_beta start_addrs_allocated ka_blocks intro: start_tid_start_addrs[OF wf_prog_wf_syscls[OF wf] ok])
  ultimately have "red_mthr.if.hb_completion ?start_state (lift_start_obs start_tid start_heap_obs)"
    by(rule non_speculative_read_into_hb_completion)

  thus ?thesis using wf_prog_wf_syscls[OF wf] J_start_state_sconf_type_ok[OF wf wf_start]
    by(rule sc_legal)(rule ka_allocated)
qed

lemma J_jmm_consistent:
  assumes wf: "wf_J_prog P"
  and hrt: "heap_read_typeable hconf P"
  and wf_start: "wf_start_state P C M vs"
  and ka: "(ka_Val ` set vs)  set start_addrs"
  shows "jmm_consistent (J_ℰ P C M vs status) P"
  (is "jmm_consistent ?ℰ P")
proof -
  interpret drf "?ℰ" P using assms by(rule J_drf)
  interpret sc_legal "?ℰ" P using assms by(rule J_sc_legal)
  show ?thesis by unfold_locales
qed

lemma J_ex_sc_exec:
  assumes wf: "wf_J_prog P"
  and hrt: "heap_read_typeable hconf P"
  and wf_start: "wf_start_state P C M vs"
  and ka: "(ka_Val ` set vs)  set start_addrs"
  shows "E ws. E  J_ℰ P C M vs status  P  (E, ws)   sequentially_consistent P (E, ws)"
  (is "E ws. _  ?ℰ  _")
proof -
  interpret jmm: executions_sc_hb ?ℰ P using assms by -(rule executions_sc)

  let ?start_state = "init_fin_lift_state status (J_start_state P C M vs)"
  let ?start_mrw = "mrw_values P Map.empty (map snd (lift_start_obs start_tid start_heap_obs))"

  from red_mthr.if.sequential_completion_Runs[OF red_mthr.if.cut_and_update_imp_sc_completion[OF J_cut_and_update[OF assms]] ta_seq_consist_convert_RA]
  obtain ttas where Red: "red_mthr.mthr.if.mthr.Runs P ?start_state ttas"
    and sc: "ta_seq_consist P ?start_mrw (lconcat (lmap (λ(t, ta). llist_of tao) ttas))" by blast
  let ?E = "lappend (llist_of (lift_start_obs start_tid start_heap_obs)) (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) ttas))"
  from Red have "?E  ?ℰ" by(blast intro: red_mthr.mthr.if.ℰ.intros)
  moreover from Red have tsa: "thread_start_actions_ok ?E"
    by(blast intro: red_mthr.thread_start_actions_ok_init_fin red_mthr.mthr.if.ℰ.intros)
  from sc have "ta_seq_consist P Map.empty (lmap snd ?E)"
    unfolding lmap_lappend_distrib lmap_lconcat llist.map_comp split_def o_def lmap_llist_of map_map snd_conv
    by(simp add: ta_seq_consist_lappend ta_seq_consist_start_heap_obs)
  from ta_seq_consist_imp_sequentially_consistent[OF tsa jmm.ℰ_new_actions_for_fun[OF ?E  ?ℰ] this]
  obtain ws where "sequentially_consistent P (?E, ws)" "P  (?E, ws) " by iprover
  ultimately show ?thesis by blast
qed

theorem J_consistent:
  assumes wf: "wf_J_prog P"
  and hrt: "heap_read_typeable hconf P"
  and wf_start: "wf_start_state P C M vs"
  and ka: "(ka_Val ` set vs)  set start_addrs"
  shows "E ws. legal_execution P (J_ℰ P C M vs status) (E, ws)"
proof -
  let ?ℰ = "J_ℰ P C M vs status"
  interpret sc_legal "?ℰ" P using assms by(rule J_sc_legal)
  from J_ex_sc_exec[OF assms]
  obtain E ws where "E  ?ℰ" "P  (E, ws) " "sequentially_consistent P (E, ws)" by blast
  hence "legal_execution P ?ℰ (E, ws)" by(rule SC_is_legal)
  thus ?thesis by blast
qed

end

end

Theory JMM_JVM

theory JMM_JVM
imports
  JMM_Framework
  "../JVM/JVMThreaded"
begin

sublocale JVM_heap_base < execd_mthr: 
  heap_multithreaded_base 
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write
    JVM_final "mexecd P" convert_RA
  for P
.

context JVM_heap_base begin

abbreviation JVMd_ℰ ::
  "'addr jvm_prog  cname  mname  'addr val list  status
   ('thread_id × ('addr, 'thread_id) obs_event action) llist set"
where "JVMd_ℰ P  execd_mthr.ℰ_start P JVM_local_start P"

end

end

Theory DRF_JVM

(*  Title:      JinjaThreads/MM/DRF_JVM.thy
    Author:     Andreas Lochbihler
*)

section ‹JMM Instantiation for bytecode›

theory DRF_JVM
imports
  JMM_Common
  JMM_JVM
  "../BV/BVProgressThreaded"
  SC_Legal
begin

subsection ‹DRF guarantee for the JVM›

abbreviation (input) ka_xcp :: "'addr option  'addr set"
where "ka_xcp  set_option"

primrec jvm_ka :: "'addr jvm_thread_state  'addr set"
where
  "jvm_ka (xcp, frs) = 
   ka_xcp xcp  ((stk, loc, C, M, pc)  set frs. (v  set stk. ka_Val v)  (v  set loc. ka_Val v))"

context heap begin

lemma red_external_aggr_read_mem_typeable:
  " (ta, va, h')  red_external_aggr P t a M vs h; ReadMem ad al v  set tao 
   T'. P,h  ad@al : T'"
by(auto simp add: red_external_aggr_def split_beta split: if_split_asm dest: heap_clone_read_typeable)

end

context JVM_heap_base begin

definition jvm_known_addrs :: "'thread_id  'addr jvm_thread_state  'addr set"
where "jvm_known_addrs t xcpfrs = {thread_id2addr t}  jvm_ka xcpfrs  set start_addrs"

end

context JVM_heap begin

lemma exec_instr_known_addrs:
  assumes ok: "start_heap_ok"
  and exec: "(ta, xcp', h', frs')  exec_instr i P t h stk loc C M pc frs"
  and check: "check_instr i P h stk loc C M pc frs"
  shows "jvm_known_addrs t (xcp', frs')  jvm_known_addrs t (None, (stk, loc, C, M, pc) # frs)  new_obs_addrs tao"
proof -
  
  note [simp] = jvm_known_addrs_def new_obs_addrs_def addr_of_sys_xcpt_start_addr[OF ok] subset_Un1 subset_Un2 subset_insert ka_Val_subset_new_obs_Addr_ReadMem SUP_subset_mono split_beta neq_Nil_conv tl_conv_drop set_drop_subset is_Ref_def

  from exec check show ?thesis
  proof(cases "i")
    case Load with exec check show ?thesis by auto
  next
    case (Store V) with exec check show ?thesis
      using set_update_subset_insert[of loc V]
      by(clarsimp simp del: set_update_subsetI) blast
  next
    case (Push v)
    with check have "ka_Val v = {}" by(cases v) simp_all
    with Push exec check show ?thesis by(simp)
  next
    case (CAS F D)
    then show ?thesis using exec check 
      by(clarsimp split: if_split_asm)(fastforce dest!: in_set_dropD)+
  next
    case (Invoke M' n)
    show ?thesis
    proof(cases "stk ! n = Null")
      case True with exec check Invoke show ?thesis by(simp)
    next
      case [simp]: False
      with check Invoke obtain a where stkn: "stk ! n = Addr a" "n < length stk" by auto
      hence a: "a  (v  set stk. ka_Val v)" by(fastforce dest: nth_mem)
      show ?thesis
      proof(cases "snd (snd (snd (method P (class_type_of (the (typeof_addr h (the_Addr (stk ! n))))) M'))) = Native")
        case True
        with exec check Invoke a stkn show ?thesis
          apply clarsimp
          apply(drule red_external_aggr_known_addrs_mono[OF ok], simp)
          apply(auto dest!: in_set_takeD dest: bspec subsetD split: extCallRet.split_asm simp add: has_method_def is_native.simps)
          done
      next
        case False
        with exec check Invoke a stkn show ?thesis
          by(auto simp add: set_replicate_conv_if dest!: in_set_takeD)
      qed
    qed
  next
    case Swap with exec check show ?thesis
      by(cases stk)(simp, case_tac list, auto)
  next
    case (BinOpInstr bop) with exec check show ?thesis
      using binop_known_addrs[OF ok, of bop "hd (drop (Suc 0) stk)" "hd stk"]
      apply(cases stk)
      apply(simp, case_tac list, simp)
      apply clarsimp
      apply(drule (2) binop_progress)
      apply(auto 6 2 split: sum.split_asm)
      done
  next
    case MExit with exec check show ?thesis by(auto split: if_split_asm)
  qed(clarsimp split: if_split_asm)+
qed

lemma exec_d_known_addrs_mono:
  assumes ok: "start_heap_ok"
  and exec: "mexecd P t (xcpfrs, h) ta (xcpfrs', h')"
  shows "jvm_known_addrs t xcpfrs'  jvm_known_addrs t xcpfrs  new_obs_addrs tao"
using exec
apply(cases xcpfrs)
apply(cases xcpfrs')
apply(simp add: split_beta)
apply(erule jvmd_NormalE)
apply(cases "fst xcpfrs")
 apply(fastforce simp add: check_def split_beta del: subsetI dest!: exec_instr_known_addrs[OF ok])
apply(fastforce simp add: jvm_known_addrs_def split_beta dest!: in_set_dropD)
done

lemma exec_instr_known_addrs_ReadMem:
  assumes exec: "(ta, xcp', h', frs')  exec_instr i P t h stk loc C M pc frs"
  and check: "check_instr i P h stk loc C M pc frs"
  and read: "ReadMem ad al v  set tao"
  shows "ad  jvm_known_addrs t (None, (stk, loc, C, M, pc) # frs)"
using assms
proof(cases i)
  case ALoad thus ?thesis using assms
    by(cases stk)(case_tac [2] list, auto simp add: split_beta is_Ref_def jvm_known_addrs_def split: if_split_asm)
next
  case (Invoke M n)
  with check have "stk ! n  Null  the_Addr (stk ! n)  ka_Val (stk ! n)" "stk ! n  set stk"
    by(auto simp add: is_Ref_def)
  with assms Invoke show ?thesis
    by(auto simp add: split_beta is_Ref_def simp del: ka_Val.simps nth_mem split: if_split_asm dest!: red_external_aggr_known_addrs_ReadMem in_set_takeD del: is_AddrE)(auto simp add: jvm_known_addrs_def simp del: ka_Val.simps nth_mem del: is_AddrE)
next
  case Getfield thus ?thesis using assms
    by(auto simp add: jvm_known_addrs_def neq_Nil_conv is_Ref_def split: if_split_asm)
next
  case CAS thus ?thesis using assms
    apply(cases stk; simp)
    subgoal for v stk
      apply(cases stk; simp)
      subgoal for v stk
        by(cases stk)(auto split: if_split_asm simp add: jvm_known_addrs_def is_Ref_def)
      done
    done
qed(auto simp add: split_beta is_Ref_def neq_Nil_conv split: if_split_asm)

lemma mexecd_known_addrs_ReadMem:
  " mexecd P t (xcpfrs, h) ta (xcpfrs', h'); ReadMem ad al v  set tao 
   ad  jvm_known_addrs t xcpfrs"
apply(cases xcpfrs)
apply(cases xcpfrs')
apply simp
apply(erule jvmd_NormalE)
apply(cases "fst xcpfrs")
apply(auto simp add: check_def dest: exec_instr_known_addrs_ReadMem)
done

lemma exec_instr_known_addrs_WriteMem:
  assumes exec: "(ta, xcp', h', frs')  exec_instr i P t h stk loc C M pc frs"
  and check: "check_instr i P h stk loc C M pc frs"
  and "write": "tao ! n = WriteMem ad al (Addr a)" "n < length tao"
  shows "a  jvm_known_addrs t (None, (stk, loc, C, M, pc) # frs)  a  new_obs_addrs (take n tao)"
using assms
proof(cases i)
  case (Invoke M n)
  with check have "stk ! n  Null  the_Addr (stk ! n)  ka_Val (stk ! n)" "stk ! n  set stk"
    by(auto simp add: is_Ref_def)
  thus ?thesis using assms Invoke
    by(auto simp add: is_Ref_def split_beta split: if_split_asm simp del: ka_Val.simps nth_mem dest!: red_external_aggr_known_addrs_WriteMem in_set_takeD del: is_AddrE)(auto simp add: jvm_known_addrs_def del: is_AddrE)
next
  case AStore with assms show ?thesis
    by(cases stk)(auto simp add: jvm_known_addrs_def split: if_split_asm)
next
  case Putfield with assms show ?thesis
    by(cases stk)(auto simp add: jvm_known_addrs_def split: if_split_asm)
next
  case CAS with assms show ?thesis
    apply(cases stk; simp)
    subgoal for v stk
      apply(cases stk; simp)
      subgoal for v stk
        by(cases stk)(auto split: if_split_asm simp add: take_Cons' jvm_known_addrs_def)
      done
    done
qed(auto simp add: split_beta split: if_split_asm)

lemma mexecd_known_addrs_WriteMem:
  " mexecd P t (xcpfrs, h) ta (xcpfrs', h'); tao ! n = WriteMem ad al (Addr a); n < length tao 
   a  jvm_known_addrs t xcpfrs  a  new_obs_addrs (take n tao)"
apply(cases xcpfrs)
apply(cases xcpfrs')
apply simp
apply(erule jvmd_NormalE)
apply(cases "fst xcpfrs")
apply(auto simp add: check_def dest: exec_instr_known_addrs_WriteMem)
done

lemma exec_instr_known_addrs_new_thread:
  assumes exec: "(ta, xcp', h', frs')  exec_instr i P t h stk loc C M pc frs"
  and check: "check_instr i P h stk loc C M pc frs"
  and new: "NewThread t' x' h''  set tat"
  shows "jvm_known_addrs t' x'  jvm_known_addrs t (None, (stk, loc, C, M, pc) # frs)"
using assms
proof(cases i)
  case (Invoke M n)
  with assms have "stk ! n  Null  the_Addr (stk ! n)  ka_Val (stk ! n)  thread_id2addr (addr2thread_id (the_Addr (stk ! n))) = the_Addr (stk ! n)" "stk ! n  set stk"
    apply(auto simp add: is_Ref_def split: if_split_asm)
    apply(frule red_external_aggr_NewThread_idD, simp, simp)
    apply(drule red_external_aggr_new_thread_sub_thread)
    apply(auto intro: addr2thread_id_inverse)
    done
  with assms Invoke show ?thesis
    apply(auto simp add: is_Ref_def split_beta split: if_split_asm simp del: nth_mem del: is_AddrE)
    apply(drule red_external_aggr_NewThread_idD)
    apply(auto simp add: extNTA2JVM_def jvm_known_addrs_def split_beta simp del: nth_mem del: is_AddrE)
    done
qed(auto simp add: split_beta split: if_split_asm)

lemma mexecd_known_addrs_new_thread:
  " mexecd P t (xcpfrs, h) ta (xcpfrs', h'); NewThread t' x' h''  set tat 
   jvm_known_addrs t' x'  jvm_known_addrs t xcpfrs"
apply(cases xcpfrs)
apply(cases xcpfrs')
apply simp
apply(erule jvmd_NormalE)
apply(cases "fst xcpfrs")
apply(auto 4 3 simp add: check_def dest: exec_instr_known_addrs_new_thread)
done

lemma exec_instr_New_same_addr_same:
  " (ta, xcp', h', frs')  exec_instr ins P t h stk loc C M pc frs;
     tao ! i = NewHeapElem a x; i < length tao;
     tao ! j = NewHeapElem a x'; j < length tao 
   i = j"
apply(cases ins)
apply(auto simp add: nth_Cons' split: prod.split_asm if_split_asm)
apply(auto split: extCallRet.split_asm dest: red_external_aggr_New_same_addr_same)
done

lemma exec_New_same_addr_same:
  " (ta, xcp', h', frs')  exec P t (xcp, h, frs); 
     tao ! i = NewHeapElem a x; i < length tao;
     tao ! j = NewHeapElem a x'; j < length tao 
   i = j"
apply(cases "(P, t, xcp, h, frs)" rule: exec.cases)
apply(auto dest: exec_instr_New_same_addr_same)
done

lemma exec_1_d_New_same_addr_same:
  " P,t  Normal (xcp, h, frs) -ta-jvmd→ Normal (xcp', h', frs'); 
     tao ! i = NewHeapElem a x; i < length tao;
     tao ! j = NewHeapElem a x'; j < length tao 
   i = j"
by(erule jvmd_NormalE)(rule exec_New_same_addr_same)

end



locale JVM_allocated_heap = allocated_heap +
  constrains addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and allocated :: "'heap  'addr set"
  and P :: "'addr jvm_prog"

sublocale JVM_allocated_heap < JVM_heap
by(unfold_locales)

context JVM_allocated_heap begin

lemma exec_instr_allocated_mono:
  " (ta, xcp', h', frs')  exec_instr i P t h stk loc C M pc frs; check_instr i P h stk loc C M pc frs 
   allocated h  allocated h'"
apply(cases i)
apply(auto 4 4 simp add: split_beta has_method_def is_native.simps split: if_split_asm sum.split_asm intro: allocate_allocated_mono dest: heap_write_allocated_same dest!: red_external_aggr_allocated_mono del: subsetI)
done

lemma mexecd_allocated_mono:
  "mexecd P t (xcpfrs, h) ta (xcpfrs', h')  allocated h  allocated h'"
apply(cases xcpfrs)
apply(cases xcpfrs')
apply(simp)
apply(erule jvmd_NormalE)
apply(cases "fst xcpfrs")
apply(auto del: subsetI simp add: check_def dest: exec_instr_allocated_mono)
done

lemma exec_instr_allocatedD:
  " (ta, xcp', h', frs')  exec_instr i P t h stk loc C M pc frs; 
     check_instr i P h stk loc C M pc frs; NewHeapElem ad CTn  set tao 
   ad  allocated h'  ad  allocated h"
apply(cases i)
apply(auto 4 4 split: if_split_asm prod.split_asm dest: allocate_allocatedD dest!: red_external_aggr_allocatedD simp add: has_method_def is_native.simps)
done

lemma mexecd_allocatedD:
  " mexecd P t (xcpfrs, h) ta (xcpfrs', h'); NewHeapElem ad CTn  set tao  
   ad  allocated h'  ad  allocated h"
apply(cases xcpfrs)
apply(cases xcpfrs')
apply(simp)
apply(erule jvmd_NormalE)
apply(cases "fst xcpfrs")
apply(auto del: subsetI dest: exec_instr_allocatedD simp add: check_def)
done

lemma exec_instr_NewHeapElemD:
  " (ta, xcp', h', frs')  exec_instr i P t h stk loc C M pc frs; check_instr i P h stk loc C M pc frs;
     ad  allocated h'; ad  allocated h 
   CTn. NewHeapElem ad CTn  set tao"
apply(cases i)
apply(auto 4 3 split: if_split_asm prod.split_asm sum.split_asm dest: allocate_allocatedD heap_write_allocated_same dest!: red_external_aggr_NewHeapElemD simp add: is_native.simps has_method_def)
done

lemma mexecd_NewHeapElemD:
  " mexecd P t (xcpfrs, h) ta (xcpfrs', h'); ad  allocated h'; ad  allocated h 
   CTn. NewHeapElem ad CTn  set tao"
apply(cases xcpfrs)
apply(cases xcpfrs')
apply(simp)
apply(erule jvmd_NormalE)
apply(cases "fst xcpfrs")
apply(auto dest: exec_instr_NewHeapElemD simp add: check_def)
done

lemma mexecd_allocated_multithreaded:
  "allocated_multithreaded addr2thread_id thread_id2addr empty_heap allocate typeof_addr heap_write allocated JVM_final (mexecd P) P"
proof
  fix t x m ta x' m'
  assume "mexecd P t (x, m) ta (x', m')"
  thus "allocated m  allocated m'" by(rule mexecd_allocated_mono)
next
  fix x t m ta x' m' ad CTn
  assume "mexecd P t (x, m) ta (x', m')"
    and "NewHeapElem ad CTn  set tao"
  thus "ad  allocated m'  ad  allocated m" by(rule mexecd_allocatedD)
next
  fix t x m ta x' m' ad
  assume "mexecd P t (x, m) ta (x', m')"
    and "ad  allocated m'" "ad  allocated m"
  thus "CTn. NewHeapElem ad CTn  set tao" by(rule mexecd_NewHeapElemD)
next
  fix t x m ta x' m' i a CTn j CTn'
  assume "mexecd P t (x, m) ta (x', m')"
    and "tao ! i = NewHeapElem a CTn" "i < length tao"
    and "tao ! j = NewHeapElem a CTn'" "j < length tao"
  thus "i = j" by(auto dest: exec_1_d_New_same_addr_same simp add: split_beta)
qed

end

sublocale JVM_allocated_heap < execd_mthr: allocated_multithreaded 
  addr2thread_id thread_id2addr 
  spurious_wakeups
  empty_heap allocate typeof_addr heap_read heap_write allocated 
  JVM_final "mexecd P" 
  P
by(rule mexecd_allocated_multithreaded)

context JVM_allocated_heap begin

lemma mexecd_known_addrs: 
  assumes wf: "wf_prog wfmd P"
  and ok: "start_heap_ok"
  shows "known_addrs addr2thread_id thread_id2addr empty_heap allocate typeof_addr heap_write allocated jvm_known_addrs JVM_final (mexecd P) P"
proof
  fix t x m ta x' m'
  assume "mexecd P t (x, m) ta (x', m')"
  thus "jvm_known_addrs t x'  jvm_known_addrs t x  new_obs_addrs tao"
    by(rule exec_d_known_addrs_mono[OF ok])
next
  fix t x m ta x' m' t' x'' m''
  assume "mexecd P t (x, m) ta (x', m')"
    and "NewThread t' x'' m''  set tat"
  thus "jvm_known_addrs t' x''  jvm_known_addrs t x" by(rule mexecd_known_addrs_new_thread)
next
  fix t x m ta x' m' ad al v
  assume "mexecd P t (x, m) ta (x', m')"
    and "ReadMem ad al v  set tao"
  thus "ad  jvm_known_addrs t x" by(rule mexecd_known_addrs_ReadMem)
next
  fix t x m ta x' m' n ad al ad'
  assume "mexecd P t (x, m) ta (x', m')"
    and "tao ! n = WriteMem ad al (Addr ad')" "n < length tao"
  thus "ad'  jvm_known_addrs t x  ad'  new_obs_addrs (take n tao)"
    by(rule mexecd_known_addrs_WriteMem)
qed

end

context JVM_heap begin

lemma exec_instr_read_typeable:
  assumes exec: "(ta, xcp', h', frs')  exec_instr i P t h stk loc C M pc frs"
  and check: "check_instr i P h stk loc C M pc frs"
  and read: "ReadMem ad al v  set tao"
  shows "T'. P,h  ad@al : T'"
using exec check read
proof(cases i)
  case ALoad
  with assms show ?thesis
    by(fastforce simp add: split_beta is_Ref_def nat_less_iff word_sless_alt intro: addr_loc_type.intros split: if_split_asm)
next
  case (Getfield F D)
  with assms show ?thesis
    by(clarsimp simp add: split_beta is_Ref_def split: if_split_asm)(blast intro: addr_loc_type.intros dest: has_visible_field has_field_mono)
next
  case (Invoke M n)
  with exec check read obtain a vs ta' va T
    where "(ta', va, h')  red_external_aggr P t a M vs h"
    and "ReadMem ad al v  set ta'o"
    by(auto split: if_split_asm simp add: is_Ref_def)
  thus ?thesis by(rule red_external_aggr_read_mem_typeable)
next
  case (CAS F D)
  with assms show ?thesis
    by(clarsimp simp add: split_beta is_Ref_def conf_def split: if_split_asm)
      (force intro: addr_loc_type.intros dest: has_visible_field[THEN has_field_mono])
qed(auto simp add: split_beta is_Ref_def split: if_split_asm)

lemma exec_1_d_read_typeable:
  " P,t  Normal (xcp, h, frs) -ta-jvmd→ Normal (xcp', h', frs'); 
     ReadMem ad al v  set tao 
   T'. P,h  ad@al : T'"
apply(erule jvmd_NormalE)
apply(cases "(P, t, xcp, h, frs)" rule: exec.cases)
apply(auto intro: exec_instr_read_typeable simp add: check_def)
done

end

sublocale JVM_heap_base < execd_mthr: 
  if_multithreaded
    JVM_final
    "mexecd P"
    convert_RA
  for P
by(unfold_locales)

context JVM_heap_conf begin

lemma JVM_conf_read_heap_read_typed:
  "JVM_conf_read addr2thread_id thread_id2addr empty_heap allocate typeof_addr (heap_read_typed P) heap_write hconf P"
proof -
  interpret conf: heap_conf_read
    addr2thread_id thread_id2addr 
    spurious_wakeups
    empty_heap allocate typeof_addr "heap_read_typed P" heap_write hconf 
    P
    by(rule heap_conf_read_heap_read_typed)
  show ?thesis by(unfold_locales)
qed

lemma exec_instr_New_typeof_addrD:
  " (ta, xcp', h', frs')  exec_instr i P t h stk loc C M pc frs; 
     check_instr i P h stk loc C M pc frs; hconf h;
     NewHeapElem a x  set tao 
   typeof_addr h' a = Some x"
apply(cases i)
apply(auto dest: allocate_SomeD split: prod.split_asm if_split_asm)
apply(auto 4 4 split: extCallRet.split_asm dest!: red_external_aggr_New_typeof_addrD simp add: has_method_def is_native.simps)
done

lemma exec_1_d_New_typeof_addrD:
  " P,t  Normal (xcp, h, frs) -ta-jvmd→ Normal (xcp', h', frs'); NewHeapElem a x  set tao; hconf h 
   typeof_addr h' a = Some x"
apply(erule jvmd_NormalE)
apply(cases "xcp")
apply(auto dest: exec_instr_New_typeof_addrD simp add: check_def)
done

lemma exec_instr_non_speculative_typeable:
  assumes exec: "(ta, xcp', h', frs')  exec_instr i P t h stk loc C M pc frs"
  and check: "check_instr i P h stk loc C M pc frs"
  and sc: "non_speculative P vs (llist_of (map NormalAction tao))"
  and vs_conf: "vs_conf P h vs"
  and hconf: "hconf h"
  shows "(ta, xcp', h', frs')  JVM_heap_base.exec_instr addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr (heap_read_typed P) heap_write i P t h stk loc C M pc frs"
proof -
  note [simp] = JVM_heap_base.exec_instr.simps
    and [split] = if_split_asm prod.split_asm sum.split_asm
    and [split del] = if_split
  from assms show "?thesis"
  proof(cases i)
    case ALoad with assms show ?thesis
      by(auto 4 3 intro!: heap_read_typedI dest: vs_confD addr_loc_type_fun)
  next
    case Getfield with assms show ?thesis
      by(auto 4 3 intro!: heap_read_typedI dest: vs_confD addr_loc_type_fun)
  next
    case CAS with assms show ?thesis
      by(auto 4 3 intro!: heap_read_typedI dest: vs_confD addr_loc_type_fun)
  next
    case Invoke with assms show ?thesis
      by(fastforce dest: red_external_aggr_non_speculative_typeable simp add: has_method_def is_native.simps)
  qed(auto)
qed

lemma exec_instr_non_speculative_vs_conf:
  assumes exec: "(ta, xcp', h', frs')  exec_instr i P t h stk loc C M pc frs"
  and check: "check_instr i P h stk loc C M pc frs"
  and sc: "non_speculative P vs (llist_of (take n (map NormalAction tao)))"
  and vs_conf: "vs_conf P h vs"
  and hconf: "hconf h"
  shows "vs_conf P h' (w_values P vs (take n (map NormalAction tao)))"
proof -
  note [simp] = JVM_heap_base.exec_instr.simps take_Cons'
    and [split] = if_split_asm prod.split_asm sum.split_asm
    and [split del] = if_split
  from assms show ?thesis
  proof(cases i)
    case New with assms show ?thesis
      by(auto 4 4 dest: hext_allocate vs_conf_allocate intro: vs_conf_hext)
  next
    case NewArray with assms show ?thesis
      by(auto 4 4 dest: hext_allocate vs_conf_allocate intro: vs_conf_hext cong: if_cong)
  next
    case Invoke with assms show ?thesis
      by(fastforce dest: red_external_aggr_non_speculative_vs_conf simp add: has_method_def is_native.simps)
  next
    case AStore
    { 
      assume "hd (tl (tl stk))  Null"
        and "¬ the_Intg (hd (tl stk))  <s 0"
        and "¬ int (alen_of_htype (the (typeof_addr h (the_Addr (hd (tl (tl stk)))))))  sint (the_Intg (hd (tl stk)))"
        and "P  the (typeofh (hd stk))  the_Array (ty_of_htype (the (typeof_addr h (the_Addr (hd (tl (tl stk)))))))"
      moreover hence "nat (sint (the_Intg (hd (tl stk)))) < alen_of_htype (the (typeof_addr h (the_Addr (hd (tl (tl stk))))))"
        by(auto simp add: not_le nat_less_iff word_sle_eq word_sless_eq not_less)
      with assms AStore have "nat (sint (the_Intg (hd (tl stk)))) < alen_of_htype (the (typeof_addr h' (the_Addr (hd (tl (tl stk))))))"
        by(auto dest!: hext_arrD hext_heap_write)
      ultimately have "T. P,h'  the_Addr (hd (tl (tl stk)))@ACell (nat (sint (the_Intg (hd (tl stk))))) : T  P,h'  hd stk :≤ T"
        using assms AStore
        by(auto 4 4 simp add: is_Ref_def conf_def dest!: hext_heap_write dest: hext_arrD intro!: addr_loc_type.intros intro: typeof_addr_hext_mono type_of_hext_type_of) }
    thus ?thesis using assms AStore
      by(auto intro!: vs_confI)(blast intro: addr_loc_type_hext_mono conf_hext dest: hext_heap_write vs_confD)+
  next
    case Putfield
    show ?thesis using assms Putfield
      by(auto intro!: vs_confI dest!: hext_heap_write)(blast intro: addr_loc_type.intros addr_loc_type_hext_mono typeof_addr_hext_mono has_field_mono[OF has_visible_field] conf_hext dest: vs_confD)+
  next
    case CAS
    show ?thesis using assms CAS
      by(auto intro!: vs_confI dest!: hext_heap_write)(blast intro: addr_loc_type.intros addr_loc_type_hext_mono typeof_addr_hext_mono has_field_mono[OF has_visible_field] conf_hext dest: vs_confD)+
  qed(auto)
qed

lemma mexecd_non_speculative_typeable:
  " P,t  Normal (xcp, h, stk) -ta-jvmd→ Normal (xcp', h', frs'); non_speculative P vs (llist_of (map NormalAction tao));
    vs_conf P h vs; hconf h 
   JVM_heap_base.exec_1_d addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr (heap_read_typed P) heap_write P t (Normal (xcp, h, stk)) ta (Normal (xcp', h', frs'))"
apply(erule jvmd_NormalE)
apply(cases xcp)
apply(auto intro!: JVM_heap_base.exec_1_d.intros simp add: JVM_heap_base.exec_d_def check_def JVM_heap_base.exec.simps intro: exec_instr_non_speculative_typeable)
done

lemma mexecd_non_speculative_vs_conf:
  " P,t  Normal (xcp, h, stk) -ta-jvmd→ Normal (xcp', h', frs');
    non_speculative P vs (llist_of (take n (map NormalAction tao)));
    vs_conf P h vs; hconf h 
   vs_conf P h' (w_values P vs (take n (map NormalAction tao)))"
apply(erule jvmd_NormalE)
apply(cases xcp)
apply(auto intro!: JVM_heap_base.exec_1_d.intros simp add: JVM_heap_base.exec_d_def check_def JVM_heap_base.exec.simps intro: exec_instr_non_speculative_vs_conf)
done

end

locale JVM_allocated_heap_conf = 
  JVM_heap_conf 
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write hconf
    P
  +
  JVM_allocated_heap 
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write
    allocated
    P
  for addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and hconf :: "'heap  bool"
  and allocated :: "'heap  'addr set"
  and P :: "'addr jvm_prog"
begin

lemma mexecd_known_addrs_typing:
  assumes wf: "wf_jvm_progΦ P"
  and ok: "start_heap_ok"
  shows "known_addrs_typing addr2thread_id thread_id2addr empty_heap allocate typeof_addr heap_write allocated jvm_known_addrs JVM_final (mexecd P) (λt (xcp, frstls) h. Φ  t: (xcp, h, frstls) ) P"
proof -
  from wf obtain wf_md where "wf_prog wf_md P" by(blast dest: wt_jvm_progD)
  then
  interpret known_addrs
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write 
    allocated jvm_known_addrs
    JVM_final "mexecd P" P
    using ok by(rule mexecd_known_addrs)
  
  show ?thesis
  proof
    fix t x m ta x' m'
    assume "mexecd P t (x, m) ta (x', m')"
    thus "m  m'" by(auto simp add: split_beta intro: exec_1_d_hext)
  next
    fix t x m ta x' m' vs
    assume exec: "mexecd P t (x, m) ta (x', m')"
      and ts_ok: "(λ(xcp, frstls) h. Φ  t:(xcp, h, frstls) ) x m"
      and vs: "vs_conf P m vs"
      and ns: "non_speculative P vs (llist_of (map NormalAction tao))"

    let ?mexecd = "JVM_heap_base.mexecd addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr (heap_read_typed P) heap_write P"    
    have lift: "lifting_wf JVM_final ?mexecd (λt (xcp, frstls) h. Φ  t: (xcp, h, frstls) )"
      by(intro JVM_conf_read.lifting_wf_correct_state_d JVM_conf_read_heap_read_typed wf)

    from exec ns vs ts_ok have exec': "?mexecd t (x, m) ta (x', m')"
      by(auto simp add: split_beta correct_state_def dest: mexecd_non_speculative_typeable)
    thus "(λ(xcp, frstls) h. Φ  t:(xcp, h, frstls) ) x' m'" using ts_ok
      by(rule lifting_wf.preserves_red[OF lift])
    {
      fix t'' x'' m''
      assume New: "NewThread t'' x'' m''  set tat"
      with exec have "m'' = snd (x', m')" by(rule execd_mthr.new_thread_memory)
      thus "(λ(xcp, frstls) h. Φ  t'':(xcp, h, frstls) ) x'' m''"
        using lifting_wf.preserves_NewThread[where ?r="?mexecd", OF lift exec' ts_ok] New
        by auto }
    { fix t'' x''
      assume "(λ(xcp, frstls) h. Φ  t'':(xcp, h, frstls) ) x'' m"
      with lift exec' ts_ok show "(λ(xcp, frstls) h. Φ  t'':(xcp, h, frstls) ) x'' m'"
        by(rule lifting_wf.preserves_other) }
  next
    fix t x m ta x' m' vs n
    assume exec: "mexecd P t (x, m) ta (x', m')"
      and ts_ok: "(λ(xcp, frstls) h. Φ  t:(xcp, h, frstls) ) x m"
      and vs: "vs_conf P m vs"
      and ns: "non_speculative P vs (llist_of (take n (map NormalAction tao)))"
    thus "vs_conf P m' (w_values P vs (take n (map NormalAction tao)))"
      by(auto simp add: correct_state_def dest: mexecd_non_speculative_vs_conf)
  next
    fix t x m ta x' m' ad al v
    assume "mexecd P t (x, m) ta (x', m')"
      and "(λ(xcp, frstls) h. Φ  t:(xcp, h, frstls) ) x m"
      and "ReadMem ad al v  set tao"
    thus "T. P,m  ad@al : T"
      by(auto simp add: correct_state_def split_beta dest: exec_1_d_read_typeable)
  next
    fix t x m ta x' m' ad hT
    assume "mexecd P t (x, m) ta (x', m')"
      and "(λ(xcp, frstls) h. Φ  t:(xcp, h, frstls) ) x m"
      and "NewHeapElem ad hT  set tao"
    thus "typeof_addr m' ad = hT"
      by(auto dest: exec_1_d_New_typeof_addrD[where x="hT"] simp add: split_beta correct_state_def)
  qed
qed

lemma executions_sc:
  assumes wf: "wf_jvm_progΦ P"
  and wf_start: "wf_start_state P C M vs"
  and vs2: "(ka_Val ` set vs)  set start_addrs"
  shows "executions_sc_hb (JVMd_ℰ P C M vs status) P"
    (is "executions_sc_hb ?E P")
proof -
  from wf_start obtain Ts T meth D where ok: "start_heap_ok"
    and sees: "P  C sees M:TsT=meth in D"
    and vs1: "P,start_heap  vs [:≤] Ts" by cases

  interpret known_addrs_typing
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write 
    allocated jvm_known_addrs
    JVM_final "mexecd P" "λt (xcp, frstls) h. Φ  t: (xcp, h, frstls) " P
    using wf ok by(rule mexecd_known_addrs_typing)
  
  from wf obtain wf_md where wf': "wf_prog wf_md P" by(blast dest: wt_jvm_progD)
  hence "wf_syscls P" by(rule wf_prog_wf_syscls) 
  thus ?thesis
  proof(rule executions_sc_hb)
    from correct_jvm_state_initial[OF wf wf_start]
    show "correct_state_ts Φ (thr (JVM_start_state P C M vs)) start_heap"
      by(simp add: correct_jvm_state_def start_state_def split_beta)
  next
    show "jvm_known_addrs start_tid ((λ(mxs, mxl0, b) vs. (None, [([], Null # vs @ replicate mxl0 undefined_value, fst (method P C M), M, 0)])) (the (snd (snd (snd (method P C M))))) vs)  allocated start_heap"
      using vs2
      by(auto simp add: split_beta start_addrs_allocated jvm_known_addrs_def intro: start_tid_start_addrs[OF ‹wf_syscls P ok])
  qed
qed

end

declare split_paired_Ex [simp del]
declare eq_upto_seq_inconsist_simps [simp]

context JVM_progress begin

abbreviation (input) jvm_non_speculative_read_bound :: nat where
  "jvm_non_speculative_read_bound  2"

lemma exec_instr_non_speculative_read:
  assumes hrt: "heap_read_typeable hconf P"
  and vs: "vs_conf P (shr s) vs"
  and hconf: "hconf (shr s)"
  and exec_i: "(ta, xcp', h', frs')  exec_instr i P t (shr s) stk loc C M pc frs"
  and check: "check_instr i P (shr s) stk loc C M pc frs"
  and aok: "execd_mthr.mthr.if.actions_ok s t ta"
  and i: "I < length tao"
  and read: "tao ! I = ReadMem a'' al'' v"
  and v': "v'  w_values P vs (map NormalAction (take I tao)) (a'', al'')"
  and ns: "non_speculative P vs (llist_of (map NormalAction (take I tao)))"
  shows "ta' xcp'' h'' frs''. (ta', xcp'', h'', frs'')  exec_instr i P t (shr s) stk loc C M pc frs 
           execd_mthr.mthr.if.actions_ok s t ta'  
           I < length ta'o  take I ta'o = take I tao  
           ta'o ! I = ReadMem a'' al'' v'  
           length ta'o  max jvm_non_speculative_read_bound (length tao)"
using exec_i i read
proof(cases i)
  case [simp]: ALoad
  let ?a = "the_Addr (hd (tl stk))"
  let ?i = "the_Intg (hd stk)"
  from exec_i i read have Null: "hd (tl stk)  Null"
    and bounds: "0 <=s ?i" "sint ?i < int (alen_of_htype (the (typeof_addr (shr s) ?a)))"
    and [simp]: "I = 0" "a'' = ?a" "al'' = ACell (nat (sint ?i))"
    by(auto split: if_split_asm)

  from Null check obtain a T n 
    where a: "length stk > 1" "hd (tl stk) = Addr a"
    and type: "typeof_addr (shr s) ?a = Array_type T n" by(fastforce simp add: is_Ref_def)
  from bounds type have "nat (sint ?i) < n"
    by (simp add: word_sle_eq nat_less_iff)
  with type have adal: "P,shr s  ?a@ACell (nat (sint ?i)) : T"
    by(rule addr_loc_type.intros)
  from v' vs adal have "P,shr s  v' :≤ T" by(auto dest!: vs_confD dest: addr_loc_type_fun)
  with hrt adal have "heap_read (shr s) ?a (ACell (nat (sint ?i))) v'" using hconf by(rule heap_read_typeableD)
  with type bounds Null aok exec_i show ?thesis by(fastforce)
next
  case [simp]: (Getfield F D)
  let ?a = "the_Addr (hd stk)"

  from exec_i i read have Null: "hd stk  Null"
    and [simp]: "I = 0" "a'' = ?a" "al'' = CField D F"
    by(auto split: if_split_asm)
  with check obtain U T fm C' a
    where sees: "P  D sees F:T (fm) in D"
    and type: "typeof_addr (shr s) ?a = U" 
    and sub: "P  class_type_of U * D" 
    and a: "hd stk = Addr a" "length stk > 0" by(auto simp add: is_Ref_def)
  from has_visible_field[OF sees] sub
  have "P  class_type_of U has F:T (fm) in D" by(rule has_field_mono)
  with type have adal: "P,shr s  ?a@CField D F : T"
    by(rule addr_loc_type.intros)
  from v' vs adal have "P,shr s  v' :≤ T" by(auto dest!: vs_confD dest: addr_loc_type_fun)  
  with hrt adal have "heap_read (shr s) ?a (CField D F) v'" using hconf by(rule heap_read_typeableD)
  with type Null aok exec_i show ?thesis by(fastforce)
next
  case [simp]: (CAS F D)
  let ?a = "the_Addr (hd (tl (tl stk)))"

  from exec_i i read have Null: "hd (tl (tl stk))  Null"
    and [simp]: "I = 0" "a'' = ?a" "al'' = CField D F"
    by(auto split: if_split_asm simp add: nth_Cons')
  with check obtain U T fm C' a
    where sees: "P  D sees F:T (fm) in D"
    and type: "typeof_addr (shr s) ?a = U" 
    and sub: "P  class_type_of U * D" 
    and a: "hd (tl (tl stk)) = Addr a" "length stk > 2" 
    and v: "P,shr s  hd stk :≤ T"
    by(auto simp add: is_Ref_def)
  from has_visible_field[OF sees] sub
  have "P  class_type_of U has F:T (fm) in D" by(rule has_field_mono)
  with type have adal: "P,shr s  ?a@CField D F : T"
    by(rule addr_loc_type.intros)
  from v' vs adal have "P,shr s  v' :≤ T" by(auto dest!: vs_confD dest: addr_loc_type_fun)  
  with hrt adal have read: "heap_read (shr s) ?a (CField D F) v'" using hconf by(rule heap_read_typeableD)
  show ?thesis
  proof(cases "v' = hd (tl stk)")
    case True
    from heap_write_total[OF hconf adal v] a obtain h'
      where "heap_write (shr s) a (CField D F) (hd stk) h'" by auto
    then show ?thesis using read a True aok exec_i by fastforce
  next
    case False
    then show ?thesis using read a aok exec_i
      by(fastforce intro!: disjI2)
  qed
next
  case [simp]: (Invoke M n)
  let ?a = "the_Addr (stk ! n)"
  let ?vs = "rev (take n stk)"
  from exec_i i read have Null: "stk ! n  Null" 
    and iec: "snd (snd (snd (method P (class_type_of (the (typeof_addr (shr s) ?a))) M))) = Native"
    by(auto split: if_split_asm)
  with check obtain a T Ts Tr D
    where a: "stk ! n = Addr a" "n < length stk"
    and type: "typeof_addr (shr s) ?a = T"
    and extwt: "P  class_type_of T sees M:TsTr = Native in D" "DM(Ts) :: Tr"
    by(auto simp add: is_Ref_def has_method_def)
  from extwt have native: "is_native P T M" by(auto simp add: is_native.simps)
  from Null iec type exec_i obtain ta' va
    where red: "(ta', va, h')  red_external_aggr P t ?a M ?vs (shr s)"
    and ta: "ta = extTA2JVM P ta'" by(fastforce)
  from aok ta have aok': "execd_mthr.mthr.if.actions_ok s t ta'" by simp
  from red_external_aggr_non_speculative_read[OF hrt vs red[unfolded a the_Addr.simps] _ aok' hconf, of I a'' al'' v v']
    native type i read v' ns a ta
  obtain ta'' va'' h''
    where "(ta'', va'', h'')  red_external_aggr P t a M (rev (take n stk)) (shr s)"
    and "execd_mthr.mthr.if.actions_ok s t ta''"
    and "I < length ta''o" "take I ta''o = take I ta'o" 
    and "ta''o ! I = ReadMem a'' al'' v'" "length ta''o  length ta'o" by auto
  thus ?thesis using Null iec ta extwt a type
    by(cases va'') force+
qed(auto simp add: split_beta split: if_split_asm)

lemma exec_1_d_non_speculative_read:
  assumes hrt: "heap_read_typeable hconf P"
  and vs: "vs_conf P (shr s) vs"
  and exec: "P,t  Normal (xcp, shr s, frs) -ta-jvmd→ Normal (xcp', h', frs')"
  and aok: "execd_mthr.mthr.if.actions_ok s t ta"
  and hconf: "hconf (shr s)"
  and i: "I < length tao"
  and read: "tao ! I = ReadMem a'' al'' v"
  and v': "v'  w_values P vs (map NormalAction (take I tao)) (a'', al'')"
  and ns: "non_speculative P vs (llist_of (map NormalAction (take I tao)))"
  shows "ta' xcp'' h'' frs''. P,t  Normal (xcp, shr s, frs) -ta'-jvmd→ Normal (xcp'', h'', frs'') 
           execd_mthr.mthr.if.actions_ok s t ta'  
           I < length ta'o  take I ta'o = take I tao  
           ta'o ! I = ReadMem a'' al'' v'  
           length ta'o  max jvm_non_speculative_read_bound (length tao)"
using assms
apply -
apply(erule jvmd_NormalE)
apply(cases "(P, t, xcp, shr s, frs)" rule: exec.cases)
  apply simp
 defer
 apply simp
apply clarsimp
apply(drule (3) exec_instr_non_speculative_read)
      apply(clarsimp simp add: check_def has_method_def)
     apply simp
    apply(rule i)
   apply(rule read)
  apply(rule v')
 apply(rule ns)
apply(clarsimp simp add: exec_1_d.simps exec_d_def)
done

end

declare split_paired_Ex [simp]
declare eq_upto_seq_inconsist_simps [simp del]

locale JVM_allocated_progress = 
  JVM_progress
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write hconf
    P
  +
  JVM_allocated_heap_conf
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write hconf
    allocated
    P
  for addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and hconf :: "'heap  bool"
  and allocated :: "'heap  'addr set"
  and P :: "'addr jvm_prog"
begin

lemma non_speculative_read:
  assumes wf: "wf_jvm_progΦ P"
  and hrt: "heap_read_typeable hconf P"
  and wf_start: "wf_start_state P C M vs"
  and ka: "(ka_Val ` set vs)  set start_addrs"
  shows "execd_mthr.if.non_speculative_read jvm_non_speculative_read_bound
      (init_fin_lift_state status (JVM_start_state P C M vs)) 
      (w_values P (λ_. {}) (map snd (lift_start_obs start_tid start_heap_obs)))"
  (is "execd_mthr.if.non_speculative_read _ ?start_state ?start_vs")
proof(rule execd_mthr.if.non_speculative_readI)
  fix ttas s' t x ta x' m' i ad al v v'

  assume τRed: "execd_mthr.mthr.if.RedT P ?start_state ttas s'"
    and sc: "non_speculative P ?start_vs (llist_of (concat (map (λ(t, ta). tao) ttas)))"
    and ts't: "thr s' t = (x, no_wait_locks)"
    and red: "execd_mthr.init_fin P t (x, shr s') ta (x', m')"
    and aok: "execd_mthr.mthr.if.actions_ok s' t ta"
    and i: "i < length tao"
    and ns': "non_speculative P (w_values P ?start_vs (concat (map (λ(t, ta). tao) ttas))) (llist_of (take i tao))"
    and read: "tao ! i = NormalAction (ReadMem ad al v)"
    and v': "v'  w_values P ?start_vs (concat (map (λ(t, ta). tao) ttas) @ take i tao) (ad, al)"

  from wf_start obtain Ts T meth D where ok: "start_heap_ok"
    and sees: "P  C sees M:TsT = meth in D"
    and conf: "P,start_heap  vs [:≤] Ts" by cases

  let ?conv = "λttas. concat (map (λ(t, ta). tao) ttas)"
  let ?vs' = "w_values P ?start_vs (?conv ttas)"
  let ?wt_ok = "init_fin_lift (λt (xcp, frstls) h. Φ  t: (xcp, h, frstls) )"
  let ?start_obs = "map snd (lift_start_obs start_tid start_heap_obs)"

  from wf obtain wf_md where wf': "wf_prog wf_md P" by(blast dest: wt_jvm_progD)

  interpret known_addrs_typing
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write 
    allocated jvm_known_addrs
    JVM_final "mexecd P" "λt (xcp, frstls) h. Φ  t: (xcp, h, frstls) "
    using wf ok by(rule mexecd_known_addrs_typing)

  from conf have len2: "length vs = length Ts" by(rule list_all2_lengthD)

  from correct_jvm_state_initial[OF wf wf_start]
  have "correct_state_ts Φ (thr (JVM_start_state P C M vs)) start_heap"
    by(simp add: correct_jvm_state_def start_state_def split_beta)
  hence ts_ok_start: "ts_ok ?wt_ok (thr ?start_state) (shr ?start_state)"
    unfolding ts_ok_init_fin_lift_init_fin_lift_state by(simp add: start_state_def split_beta)

  have sc': "non_speculative P ?start_vs (lmap snd (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) (llist_of ttas))))"
    using sc by(simp add: lmap_lconcat llist.map_comp o_def split_def lconcat_llist_of[symmetric])
  from start_state_vs_conf[OF wf_prog_wf_syscls[OF wf']]
  have vs_conf_start: "vs_conf P (shr ?start_state) ?start_vs"
    by(simp add:init_fin_lift_state_conv_simps start_state_def split_beta)
  with τRed ts_ok_start sc
  have wt': "ts_ok ?wt_ok (thr s') (shr s')"
    and vs': "vs_conf P (shr s') ?vs'" by(rule if_RedT_non_speculative_invar)+

  from red i read obtain xcp frs xcp' frs' ta'
    where x: "x = (Running, xcp, frs)" and x': "x' = (Running, xcp', frs')"
    and ta: "ta = convert_TA_initial (convert_obs_initial ta')"
    and red': "P,t  Normal (xcp, shr s', frs) -ta'-jvmd→ Normal (xcp', m', frs')"
    by cases fastforce+

  from ts't wt' x have hconf: "hconf (shr s')" by(auto dest!: ts_okD simp add: correct_state_def)

  have aok': "execd_mthr.mthr.if.actions_ok s' t ta'" using aok unfolding ta by simp
  
  from i read v' ns' ta have "i < length ta'o" 
    and "ta'o ! i = ReadMem ad al v"
    and "v'  w_values P ?vs' (map NormalAction (take i ta'o)) (ad, al)"
    and "non_speculative P ?vs' (llist_of (map NormalAction (take i ta'o)))"
    by(simp_all add: take_map)

  from exec_1_d_non_speculative_read[OF hrt vs' red' aok' hconf this]
  obtain ta'' xcp'' frs'' h''
    where red'': "P,t  Normal (xcp, shr s', frs) -ta''-jvmd→ Normal (xcp'', h'', frs'')"
    and aok'': "execd_mthr.mthr.if.actions_ok s' t ta''"
    and i'': " i < length ta''o"
    and eq'': "take i ta''o = take i ta'o"
    and read'': "ta''o ! i = ReadMem ad al v'"
    and len'': "length ta''o  max jvm_non_speculative_read_bound (length ta'o)" by blast

  let ?x' = "(Running, xcp'', frs'')"
  let ?ta' = "convert_TA_initial (convert_obs_initial ta'')"
  from red'' have "execd_mthr.init_fin P t (x, shr s') ?ta' (?x', h'')"
    unfolding x by -(rule execd_mthr.init_fin.NormalAction, simp)
  moreover from aok'' have "execd_mthr.mthr.if.actions_ok s' t ?ta'" by simp
  moreover from i'' have "i < length ?ta'o" by simp
  moreover from eq'' have "take i ?ta'o = take i tao" unfolding ta by(simp add: take_map)
  moreover from read'' i'' have "?ta'o ! i = NormalAction (ReadMem ad al v')" by(simp add: nth_map)
  moreover from len'' have "length ?ta'o  max jvm_non_speculative_read_bound (length tao)" 
    unfolding ta by simp
  ultimately
  show "ta' x'' m''. execd_mthr.init_fin P t (x, shr s') ta' (x'', m'') 
                      execd_mthr.mthr.if.actions_ok s' t ta' 
                      i < length ta'o  take i ta'o = take i tao 
                      ta'o ! i = NormalAction (ReadMem ad al v')  
                      length ta'o  max jvm_non_speculative_read_bound (length tao)"
    by blast
qed

lemma JVM_cut_and_update:
  assumes wf: "wf_jvm_progΦ P"
  and hrt: "heap_read_typeable hconf P" 
  and wf_start: "wf_start_state P C M vs"
  and ka: "(ka_Val ` set vs)  set start_addrs"
  shows "execd_mthr.if.cut_and_update (init_fin_lift_state status (JVM_start_state P C M vs))
           (mrw_values P Map.empty (map snd (lift_start_obs start_tid start_heap_obs)))"
proof -
  from wf_start obtain Ts T meth D where ok: "start_heap_ok"
    and sees: "P  C sees M:TsT = meth in D"
    and conf: "P,start_heap  vs [:≤] Ts" by cases

  interpret known_addrs_typing
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write 
    allocated jvm_known_addrs
    JVM_final "mexecd P" "λt (xcp, frstls) h. Φ  t: (xcp, h, frstls) "
    using wf ok by(rule mexecd_known_addrs_typing)

  let ?start_vs = "w_values P (λ_. {}) (map snd (lift_start_obs start_tid start_heap_obs))"
  let ?wt_ok = "init_fin_lift (λt (xcp, frstls) h. Φ  t: (xcp, h, frstls) )"
  let ?start_obs = "map snd (lift_start_obs start_tid start_heap_obs)"
  let ?start_state = "init_fin_lift_state status (JVM_start_state P C M vs)"

  from wf obtain wf_md where wf': "wf_prog wf_md P" by(blast dest: wt_jvm_progD)
  hence "wf_syscls P" by(rule wf_prog_wf_syscls)
  moreover
  note non_speculative_read[OF wf hrt wf_start ka]
  moreover have "ts_ok ?wt_ok (thr ?start_state) (shr ?start_state)"
    using correct_jvm_state_initial[OF wf wf_start]
    by(simp add: correct_jvm_state_def start_state_def split_beta)
  moreover have ka: "jvm_known_addrs start_tid ((λ(mxs, mxl0, b) vs. (None, [([], Null # vs @ replicate mxl0 undefined_value, fst (method P C M), M, 0)])) (the (snd (snd (snd (method P C M))))) vs)  allocated start_heap"
      using ka by(auto simp add: split_beta start_addrs_allocated jvm_known_addrs_def intro: start_tid_start_addrs[OF ‹wf_syscls P ok])
  ultimately show ?thesis by(rule non_speculative_read_into_cut_and_update)
qed

lemma JVM_drf:
  assumes wf: "wf_jvm_progΦ P"
  and hrt: "heap_read_typeable hconf P"
  and wf_start: "wf_start_state P C M vs"
  and ka: "(ka_Val ` set vs)  set start_addrs"
  shows "drf (JVMd_ℰ P C M vs status) P"
proof -
  from wf_start obtain Ts T meth D where ok: "start_heap_ok"
    and sees: "P  C sees M:TsT = meth in D"
    and conf: "P,start_heap  vs [:≤] Ts" by cases

  from wf obtain wf_md where wf': "wf_prog wf_md P" by(blast dest: wt_jvm_progD)
  hence "wf_syscls P" by(rule wf_prog_wf_syscls)
  with JVM_cut_and_update[OF assms]
  show ?thesis
  proof(rule known_addrs_typing.drf[OF mexecd_known_addrs_typing[OF wf ok]])
    from correct_jvm_state_initial[OF wf wf_start]
    show "correct_state_ts Φ (thr (JVM_start_state P C M vs)) start_heap"
      by(simp add: correct_jvm_state_def start_state_def split_beta)
  next
    show "jvm_known_addrs start_tid ((λ(mxs, mxl0, b) vs. (None, [([], Null # vs @ replicate mxl0 undefined_value, fst (method P C M), M, 0)])) (the (snd (snd (snd (method P C M))))) vs)  allocated start_heap"
      using ka by(auto simp add: split_beta start_addrs_allocated jvm_known_addrs_def intro: start_tid_start_addrs[OF ‹wf_syscls P ok])
  qed
qed

lemma JVM_sc_legal:
  assumes wf: "wf_jvm_progΦ P"
  and hrt: "heap_read_typeable hconf P"
  and wf_start: "wf_start_state P C M vs"
  and ka: "(ka_Val ` set vs)  set start_addrs"
shows "sc_legal (JVMd_ℰ P C M vs status) P"
proof -
  from wf_start obtain Ts T meth D where ok: "start_heap_ok"
    and sees: "P  C sees M:TsT = meth in D"
    and conf: "P,start_heap  vs [:≤] Ts" by cases

  interpret known_addrs_typing
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write 
    allocated jvm_known_addrs
    JVM_final "mexecd P" "λt (xcp, frstls) h. Φ  t: (xcp, h, frstls) "
    using wf ok by(rule mexecd_known_addrs_typing)

  from wf obtain wf_md where wf': "wf_prog wf_md P" by(blast dest: wt_jvm_progD)
  hence "wf_syscls P" by(rule wf_prog_wf_syscls)

  let ?start_vs = "w_values P (λ_. {}) (map snd (lift_start_obs start_tid start_heap_obs))"
  let ?wt_ok = "init_fin_lift (λt (xcp, frstls) h. Φ  t: (xcp, h, frstls) )"
  let ?start_obs = "map snd (lift_start_obs start_tid start_heap_obs)"
  let ?start_state = "init_fin_lift_state status (JVM_start_state P C M vs)"

  note ‹wf_syscls P non_speculative_read[OF wf hrt wf_start ka]
  moreover have "ts_ok ?wt_ok (thr ?start_state) (shr ?start_state)"
    using correct_jvm_state_initial[OF wf wf_start]
    by(simp add: correct_jvm_state_def start_state_def split_beta)
  moreover
  have ka_allocated: "jvm_known_addrs start_tid ((λ(mxs, mxl0, b) vs. (None, [([], Null # vs @ replicate mxl0 undefined_value, fst (method P C M), M, 0)])) (the (snd (snd (snd (method P C M))))) vs)  allocated start_heap"
    using ka by(auto simp add: split_beta start_addrs_allocated jvm_known_addrs_def intro: start_tid_start_addrs[OF ‹wf_syscls P ok])
  ultimately have "execd_mthr.if.hb_completion ?start_state (lift_start_obs start_tid start_heap_obs)"
    by(rule non_speculative_read_into_hb_completion)

  thus ?thesis using ‹wf_syscls P
  proof(rule sc_legal)
    from correct_jvm_state_initial[OF wf wf_start]
    show "correct_state_ts Φ (thr (JVM_start_state P C M vs)) start_heap"
      by(simp add: correct_jvm_state_def start_state_def split_beta)
  qed(rule ka_allocated)
qed

lemma JVM_jmm_consistent:
  assumes wf: "wf_jvm_progΦ P"
  and hrt: "heap_read_typeable hconf P"
  and wf_start: "wf_start_state P C M vs"
  and ka: "(ka_Val ` set vs)  set start_addrs"
  shows "jmm_consistent (JVMd_ℰ P C M vs status) P"
    (is "jmm_consistent ?ℰ P")
proof -
  interpret drf "?ℰ" P using assms by(rule JVM_drf)
  interpret sc_legal "?ℰ" P using assms by(rule JVM_sc_legal)
  show ?thesis by unfold_locales
qed

lemma JVM_ex_sc_exec:
  assumes wf: "wf_jvm_progΦ P"
  and hrt: "heap_read_typeable hconf P"
  and wf_start: "wf_start_state P C M vs"
  and ka: "(ka_Val ` set vs)  set start_addrs"
  shows "E ws. E  JVMd_ℰ P C M vs status  P  (E, ws)   sequentially_consistent P (E, ws)"
  (is "E ws. _  ?ℰ  _")
proof -
  interpret jmm: executions_sc_hb ?ℰ P using assms by -(rule executions_sc)

  let ?start_state = "init_fin_lift_state status (JVM_start_state P C M vs)"
  let ?start_mrw = "mrw_values P Map.empty (map snd (lift_start_obs start_tid start_heap_obs))"

  from execd_mthr.if.sequential_completion_Runs[OF execd_mthr.if.cut_and_update_imp_sc_completion[OF JVM_cut_and_update[OF assms]] ta_seq_consist_convert_RA]
  obtain ttas where Red: "execd_mthr.mthr.if.mthr.Runs P ?start_state ttas"
    and sc: "ta_seq_consist P ?start_mrw (lconcat (lmap (λ(t, ta). llist_of tao) ttas))" by blast
  let ?E = "lappend (llist_of (lift_start_obs start_tid start_heap_obs)) (lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) ttas))"
  from Red have "?E  ?ℰ" by(blast intro: execd_mthr.mthr.if.ℰ.intros)
  moreover from Red have tsa: "thread_start_actions_ok ?E"
    by(blast intro: execd_mthr.thread_start_actions_ok_init_fin execd_mthr.mthr.if.ℰ.intros)
  from sc have "ta_seq_consist P Map.empty (lmap snd ?E)"
    unfolding lmap_lappend_distrib lmap_lconcat llist.map_comp split_def o_def lmap_llist_of map_map snd_conv
    by(simp add: ta_seq_consist_lappend ta_seq_consist_start_heap_obs)
  from ta_seq_consist_imp_sequentially_consistent[OF tsa jmm.ℰ_new_actions_for_fun[OF ?E  ?ℰ] this]
  obtain ws where "sequentially_consistent P (?E, ws)" "P  (?E, ws) " by iprover
  ultimately show ?thesis by blast
qed

theorem JVM_consistent:
  assumes wf: "wf_jvm_progΦ P"
  and hrt: "heap_read_typeable hconf P"
  and wf_start: "wf_start_state P C M vs"
  and ka: "(ka_Val ` set vs)  set start_addrs"
  shows "E ws. legal_execution P (JVMd_ℰ P C M vs status) (E, ws)"
proof -
  let ?ℰ = "JVMd_ℰ P C M vs status"
  interpret sc_legal "?ℰ" P using assms by(rule JVM_sc_legal)
  from JVM_ex_sc_exec[OF assms]
  obtain E ws where "E  ?ℰ" "P  (E, ws) " "sequentially_consistent P (E, ws)" by blast
  hence "legal_execution P ?ℰ (E, ws)" by(rule SC_is_legal)
  thus ?thesis by blast
qed

end

text ‹
  One could now also prove that the aggressive JVM satisfies @{term drf}.
  The key would be that welltyped_commute› also holds for @{term "non_speculative"} prefixes from start.
›

end

Theory JMM_Type

(*  Title:      JinjaThreads/MM/JMM_Type.thy
    Author:     Andreas Lochbihler
*)

section ‹JMM heap implementation 1›

theory JMM_Type
imports 
  "../Common/ExternalCallWF"
  "../Common/ConformThreaded"
  JMM_Heap
begin

subsection ‹Definitions›

text ‹
  The JMM heap only stores type information.
›

type_synonym 'addr JMM_heap = "'addr  htype"

translations (type) "'addr JMM_heap" <= (type) "'addr  htype option"

abbreviation jmm_empty :: "'addr JMM_heap" where "jmm_empty == Map.empty"

definition jmm_allocate :: "'addr JMM_heap  htype  ('addr JMM_heap × 'addr) set"
where "jmm_allocate h hT = (λa. (h(a  hT), a)) ` {a. h a = None}"

definition jmm_typeof_addr :: "'addr JMM_heap  'addr  htype"
where "jmm_typeof_addr h = h"

definition jmm_heap_read :: "'addr JMM_heap  'addr  addr_loc  'addr val  bool"
where "jmm_heap_read h a ad v = True"

context
  notes [[inductive_internals]]
begin

inductive jmm_heap_write :: "'addr JMM_heap  'addr  addr_loc  'addr val  'addr JMM_heap  bool"
where "jmm_heap_write h a ad v h"

end

definition jmm_hconf :: "'m prog  'addr JMM_heap  bool" ("_ ⊢jmm _ " [51,51] 50)
where "P ⊢jmm h   ty_of_htype ` ran h  {T. is_type P T}"

definition jmm_allocated :: "'addr JMM_heap  'addr set"
where "jmm_allocated h = dom (jmm_typeof_addr h)"

definition jmm_spurious_wakeups :: bool
where "jmm_spurious_wakeups = True"

lemmas jmm_heap_ops_defs =
  jmm_allocate_def jmm_typeof_addr_def 
  jmm_heap_read_def jmm_heap_write_def
  jmm_allocated_def jmm_spurious_wakeups_def

type_synonym 'addr thread_id = "'addr"

abbreviation (input) addr2thread_id :: "'addr  'addr thread_id"
where "addr2thread_id  λx. x"

abbreviation (input) thread_id2addr :: "'addr thread_id  'addr"
where "thread_id2addr  λx. x"

interpretation jmm: heap_base
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate jmm_typeof_addr jmm_heap_read jmm_heap_write 
.

notation jmm.hext  ("_ ⊴jmm _" [51,51] 50)
notation jmm.conf ("_,_ ⊢jmm _ :≤ _"  [51,51,51,51] 50)
notation jmm.addr_loc_type ("_,_ ⊢jmm _@_ : _" [50, 50, 50, 50, 50] 51)
notation jmm.confs ("_,_ ⊢jmm _ [:≤] _"  [51,51,51,51] 50)
notation jmm.tconf ("_,_ ⊢jmm _ √t" [51,51,51] 50)

text ‹Now a variation of the JMM with a different read operation that permits to read only type-conformant values›

interpretation jmm': heap_base
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate jmm_typeof_addr "jmm.heap_read_typed P" jmm_heap_write
  for P .

notation jmm'.hext ("_ ⊴jmm'' _" [51,51] 50)
notation jmm'.conf ("_,_ ⊢jmm'' _ :≤ _"  [51,51,51,51] 50)
notation jmm'.addr_loc_type ("_,_ ⊢jmm'' _@_ : _" [50, 50, 50, 50, 50] 51)
notation jmm'.confs ("_,_ ⊢jmm'' _ [:≤] _"  [51,51,51,51] 50)
notation jmm'.tconf ("_,_ ⊢jmm'' _ √t" [51,51,51] 50)

subsection ‹Heap locale interpretations›

subsection ‹Locale heap›

lemma jmm_heap: "heap addr2thread_id thread_id2addr jmm_allocate jmm_typeof_addr jmm_heap_write P"
proof
  fix h' a h hT
  assume "(h', a)  jmm_allocate h hT"
  thus "jmm_typeof_addr h' a = hT"
    by(auto simp add: jmm_heap_ops_defs)
next
  fix h' :: "('addr :: addr) JMM_heap" and h hT a
  assume "(h', a)  jmm_allocate h hT"
  thus "h ⊴jmm h'"
    by(fastforce simp add: jmm_heap_ops_defs intro: jmm.hextI)
next
  fix h a al v and h' :: "('addr :: addr) JMM_heap"
  assume "jmm_heap_write h a al v h'"
  thus "h ⊴jmm h'" by cases auto
qed simp

interpretation jmm: heap
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate jmm_typeof_addr jmm_heap_read jmm_heap_write
  P
  for P
by(rule jmm_heap)

declare jmm.typeof_addr_thread_id2_addr_addr2thread_id [simp del]

lemmas jmm'_heap = jmm_heap

interpretation jmm': heap
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate jmm_typeof_addr "jmm.heap_read_typed P" jmm_heap_write
  P
  for P
by(rule jmm'_heap)

declare jmm'.typeof_addr_thread_id2_addr_addr2thread_id [simp del]

subsection ‹Locale heap_conf›

interpretation jmm: heap_conf_base
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate jmm_typeof_addr jmm_heap_read jmm_heap_write "jmm_hconf P"
  P
  for P .

abbreviation (input) jmm'_hconf :: "'m prog  'addr JMM_heap  bool" ("_ ⊢jmm'' _ " [51,51] 50)
where "jmm'_hconf == jmm_hconf"

interpretation jmm': heap_conf_base
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate jmm_typeof_addr "jmm.heap_read_typed P" jmm_heap_write "jmm'_hconf P"
  P
  for P .

abbreviation jmm_heap_read_typeable :: "('addr :: addr) itself  'm prog  bool"
where "jmm_heap_read_typeable tytok P  jmm.heap_read_typeable (jmm_hconf P :: 'addr JMM_heap  bool) P"

abbreviation jmm'_heap_read_typeable :: "('addr :: addr) itself  'm prog  bool"
where "jmm'_heap_read_typeable tytok P  jmm'.heap_read_typeable TYPE('m) P (jmm_hconf P :: 'addr JMM_heap  bool) P"

lemma jmm_heap_read_typeable: "jmm_heap_read_typeable tytok P"
by(rule jmm.heap_read_typeableI)(simp add: jmm_heap_read_def)

lemma jmm'_heap_read_typeable: "jmm'_heap_read_typeable tytok P"
by(rule jmm'.heap_read_typeableI)(auto simp add: jmm.heap_read_typed_def jmm_heap_read_def dest: jmm'.addr_loc_type_fun)

lemma jmm_heap_conf:
  "heap_conf addr2thread_id thread_id2addr jmm_empty jmm_allocate jmm_typeof_addr jmm_heap_write (jmm_hconf P) P"
proof
  show "P ⊢jmm jmm_empty "
    by(simp add: jmm_hconf_def)
next
  fix h a hT
  assume "jmm_typeof_addr h a = hT" "P ⊢jmm h "
  thus "is_htype P hT" by(auto simp add: jmm_hconf_def jmm_heap_ops_defs intro: ranI)
next
  fix h' h hT a
  assume "(h', a)  jmm_allocate h hT" "P ⊢jmm h " "is_htype P hT"
  thus "P ⊢jmm h' "
    by(fastforce simp add: jmm_hconf_def jmm_heap_ops_defs ran_def split: if_split_asm)
next
  fix h a al v h' T
  assume "jmm_heap_write h a al v h'" "P ⊢jmm h "
    and "jmm.addr_loc_type P h a al T" and "P,h ⊢jmm v :≤ T"
  thus "P ⊢jmm h' " by(cases) simp
qed

interpretation jmm: heap_conf
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate jmm_typeof_addr jmm_heap_read jmm_heap_write "jmm_hconf P"
  P
  for P
by(rule jmm_heap_conf)

lemmas jmm'_heap_conf = jmm_heap_conf

interpretation jmm': heap_conf
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate jmm_typeof_addr "jmm.heap_read_typed P" jmm_heap_write "jmm'_hconf P"
  P
  for P
by(rule jmm'_heap_conf)

subsection ‹Locale heap_progress›

lemma jmm_heap_progress:
  "heap_progress addr2thread_id thread_id2addr jmm_empty jmm_allocate jmm_typeof_addr jmm_heap_read jmm_heap_write (jmm_hconf P) P"
proof
  fix h a al T
  assume "P ⊢jmm h "
    and al: "jmm.addr_loc_type P h a al T"
  show "v. jmm_heap_read h a al v  P,h ⊢jmm v :≤ T"
    using jmm.defval_conf[of P h T] unfolding jmm_heap_ops_defs by blast
next
  fix h a al T v
  assume "jmm.addr_loc_type P h a al T"
  show "h'. jmm_heap_write h a al v h'"
    by(auto intro: jmm_heap_write.intros)
qed

interpretation jmm: heap_progress
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate jmm_typeof_addr jmm_heap_read jmm_heap_write "jmm_hconf P"
  P
  for P
by(rule jmm_heap_progress)

lemma jmm'_heap_progress:
  "heap_progress addr2thread_id thread_id2addr jmm_empty jmm_allocate jmm_typeof_addr (jmm.heap_read_typed P) jmm_heap_write (jmm'_hconf P) P"
proof
  fix h a al T
  assume "P ⊢jmm' h "
    and al: "jmm'.addr_loc_type P h a al T"
  thus "v. jmm.heap_read_typed P h a al v  P,h ⊢jmm' v :≤ T"
    unfolding jmm.heap_read_typed_def jmm_heap_read_def
    by(auto dest: jmm'.addr_loc_type_fun intro: jmm'.defval_conf)
next
  fix h a al T v
  assume "jmm'.addr_loc_type P h a al T"
    and "P,h ⊢jmm' v :≤ T"
  thus "h'. jmm_heap_write h a al v h'"
    by(auto intro: jmm_heap_write.intros)
qed

interpretation jmm': heap_progress
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate jmm_typeof_addr "jmm.heap_read_typed P" jmm_heap_write "jmm'_hconf P"
  P
  for P
by(rule jmm'_heap_progress)

subsection ‹Locale heap_conf_read›

lemma jmm'_heap_conf_read:
  "heap_conf_read addr2thread_id thread_id2addr jmm_empty jmm_allocate jmm_typeof_addr (jmm.heap_read_typed P) jmm_heap_write (jmm'_hconf P) P"
by(rule jmm.heap_conf_read_heap_read_typed)

interpretation jmm': heap_conf_read
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate jmm_typeof_addr "jmm.heap_read_typed P" jmm_heap_write "jmm'_hconf P"
  P
  for P
by(rule jmm'_heap_conf_read)

interpretation jmm': heap_typesafe
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate jmm_typeof_addr "jmm.heap_read_typed P" jmm_heap_write "jmm'_hconf P"
  P
  for P
..

subsection ‹Locale allocated_heap›

lemma jmm_allocated_heap: 
  "allocated_heap addr2thread_id thread_id2addr jmm_empty jmm_allocate jmm_typeof_addr jmm_heap_write jmm_allocated P"
proof
  show "jmm_allocated jmm_empty = {}" by(auto simp add: jmm_heap_ops_defs)
next
  fix h' a h hT
  assume "(h', a)  jmm_allocate h hT"
  thus "jmm_allocated h' = insert a (jmm_allocated h)  a  jmm_allocated h"
    by(auto simp add: jmm_heap_ops_defs split: if_split_asm)
next
  fix h a al v h'
  assume "jmm_heap_write h a al v h'"
  thus "jmm_allocated h' = jmm_allocated h" by cases simp
qed

interpretation jmm: allocated_heap
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate jmm_typeof_addr jmm_heap_read jmm_heap_write
  jmm_allocated
  P
  for P
by(rule jmm_allocated_heap)

lemmas jmm'_allocated_heap = jmm_allocated_heap

interpretation jmm': allocated_heap
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate jmm_typeof_addr "jmm.heap_read_typed P" jmm_heap_write
  jmm_allocated
  P
  for P
by(rule jmm'_allocated_heap)

subsection ‹Syntax translations›

notation jmm'.external_WT' ("_,_ ⊢jmm'' (__'(_')) : _" [50,0,0,0,50] 60)

abbreviation jmm'_red_external :: 
  "'m prog  'addr thread_id  'addr JMM_heap  'addr  mname  'addr val list
   ('addr :: addr, 'addr thread_id, 'addr JMM_heap) external_thread_action 
   'addr extCallRet  'addr JMM_heap  bool"
where "jmm'_red_external P  jmm'.red_external (TYPE('m)) P P"

abbreviation jmm'_red_external_syntax :: 
  "'m prog  'addr thread_id  'addr  mname  'addr val list  'addr JMM_heap
   ('addr :: addr, 'addr thread_id, 'addr JMM_heap) external_thread_action 
   'addr extCallRet  'addr JMM_heap  bool"
  ("_,_ ⊢jmm'' ((__'(_')),/_) -_→ext ((_),/(_))" [50, 0, 0, 0, 0, 0, 0, 0, 0] 51)
where
  "P,t ⊢jmm' aM(vs), h -ta→ext va, h'  jmm'_red_external P t h a M vs ta va h'"

abbreviation jmm'_red_external_aggr :: 
  "'m prog  'addr thread_id  'addr  mname  'addr val list  'addr JMM_heap 
     (('addr :: addr, 'addr thread_id, 'addr JMM_heap) external_thread_action × 'addr extCallRet × 'addr JMM_heap) set"
where "jmm'_red_external_aggr P  jmm'.red_external_aggr TYPE('m) P P"

abbreviation jmm'_heap_copy_loc :: 
  "'m prog  'addr  'addr  addr_loc  'addr JMM_heap
   ('addr :: addr, 'addr thread_id) obs_event list  'addr JMM_heap  bool"
where "jmm'_heap_copy_loc  jmm'.heap_copy_loc TYPE('m)"

abbreviation jmm'_heap_copies :: 
  "'m prog  'addr  'addr  addr_loc list  'addr JMM_heap
   ('addr :: addr, 'addr thread_id) obs_event list  'addr JMM_heap  bool"
where "jmm'_heap_copies  jmm'.heap_copies TYPE('m)"

abbreviation jmm'_heap_clone ::
  "'m prog  'addr JMM_heap  'addr  'addr JMM_heap
   (('addr :: addr, 'addr thread_id) obs_event list × 'addr) option  bool"
where "jmm'_heap_clone P  jmm'.heap_clone TYPE('m) P P"

end

Theory JMM_Compiler

(*  Title:      JinjaThreads/MM/JMM_Compiler.thy
    Author:     Andreas Lochbihler

    Compiler correctness for the JMM
*)

section ‹Compiler correctness for the JMM›

theory JMM_Compiler imports
  JMM_J
  JMM_JVM
  "../Compiler/Correctness" 
  "../Framework/FWBisimLift"
begin

lemma action_loc_aux_compP [simp]: "action_loc_aux (compP f P) = action_loc_aux P"
by(auto 4 4 elim!: action_loc_aux_cases)

lemma action_loc_compP: "action_loc (compP f P) = action_loc P"
by simp

lemma is_volatile_compP [simp]: "is_volatile (compP f P) = is_volatile P"
proof(rule ext)
  fix hT
  show "is_volatile (compP f P) hT = is_volatile P hT"
    by(cases hT) simp_all
qed

lemma saction_compP [simp]: "saction (compP f P) = saction P"
by(simp add: saction.simps fun_eq_iff)

lemma sactions_compP [simp]: "sactions (compP f P) = sactions P"
by(rule ext)(simp only: sactions_def, simp)

lemma addr_locs_compP [simp]: "addr_locs (compP f P) = addr_locs P"
by(rule ext)(case_tac x, simp_all)

lemma syncronizes_with_compP [simp]: "synchronizes_with (compP f P) = synchronizes_with P"
by(simp add: synchronizes_with.simps fun_eq_iff)

lemma sync_order_compP [simp]: "sync_order (compP f P) = sync_order P"
by(simp add: sync_order_def fun_eq_iff)

lemma sync_with_compP [simp]: "sync_with (compP f P) = sync_with P"
by(simp add: sync_with_def fun_eq_iff)

lemma po_sw_compP [simp]: "po_sw (compP f P) = po_sw P"
by(simp add: po_sw_def fun_eq_iff)

lemma happens_before_compP: "happens_before (compP f P) = happens_before P"
by simp

lemma addr_loc_default_compP [simp]: "addr_loc_default (compP f P) = addr_loc_default P"
proof(intro ext)
  fix hT al
  show "addr_loc_default (compP f P) hT al = addr_loc_default P hT al"
    by(cases "(P, hT, al)" rule: addr_loc_default.cases) simp_all
qed

lemma value_written_aux_compP [simp]: "value_written_aux (compP f P) = value_written_aux P"
proof(intro ext)
  fix a al
  show "value_written_aux (compP f P) a al = value_written_aux P a al"
    by(cases "(P, a, al)" rule: value_written_aux.cases)(simp_all add: value_written_aux.simps)
qed

lemma value_written_compP [simp]: "value_written (compP f P) = value_written P"
by(simp add: fun_eq_iff value_written.simps)

lemma is_write_seen_compP [simp]: "is_write_seen (compP f P) = is_write_seen P"
by(simp add: fun_eq_iff is_write_seen_def)

lemma justification_well_formed_compP [simp]:
  "justification_well_formed (compP f P) = justification_well_formed P"
by(simp add: fun_eq_iff justification_well_formed_def)

lemma happens_before_committed_compP [simp]:
  "happens_before_committed (compP f P) = happens_before_committed P"
by(simp add: fun_eq_iff happens_before_committed_def)

lemma happens_before_committed_weak_compP [simp]:
  "happens_before_committed_weak (compP f P) = happens_before_committed_weak P"
by(simp add: fun_eq_iff happens_before_committed_weak_def)

lemma sync_order_committed_compP [simp]:
  "sync_order_committed (compP f P) = sync_order_committed P"
by(simp add: fun_eq_iff sync_order_committed_def)

lemma value_written_committed_compP [simp]:
  "value_written_committed (compP f P) = value_written_committed P"
by(simp add: fun_eq_iff value_written_committed_def)

lemma uncommitted_reads_see_hb_compP [simp]:
  "uncommitted_reads_see_hb (compP f P) = uncommitted_reads_see_hb P"
by(simp add: fun_eq_iff uncommitted_reads_see_hb_def)

lemma external_actions_committed_compP [simp]:
  "external_actions_committed (compP f P) = external_actions_committed P"
by(simp add: fun_eq_iff external_actions_committed_def)

lemma is_justified_by_compP [simp]: "is_justified_by (compP f P) = is_justified_by P"
by(simp add: fun_eq_iff is_justified_by.simps)

lemma is_weakly_justified_by_compP [simp]: "is_weakly_justified_by (compP f P) = is_weakly_justified_by P"
by(simp add: fun_eq_iff is_weakly_justified_by.simps)

lemma legal_execution_compP: "legal_execution (compP f P) = legal_execution P"
by(simp add: fun_eq_iff gen_legal_execution.simps)

lemma weakly_legal_execution_compP: "weakly_legal_execution (compP f P) = weakly_legal_execution P"
by(simp add: fun_eq_iff gen_legal_execution.simps)

lemma most_recent_write_for_compP [simp]: 
  "most_recent_write_for (compP f P) = most_recent_write_for P"
by(simp add: fun_eq_iff most_recent_write_for.simps)

lemma sequentially_consistent_compP [simp]:
  "sequentially_consistent (compP f P) = sequentially_consistent P"
by(simp add: sequentially_consistent_def split_beta)

lemma conflict_compP [simp]: "non_volatile_conflict (compP f P) = non_volatile_conflict P"
by(simp add: fun_eq_iff non_volatile_conflict_def)

lemma correctly_synchronized_compP [simp]: 
  "correctly_synchronized (compP f P) = correctly_synchronized P"
by(simp add: fun_eq_iff correctly_synchronized_def)

lemma (in heap_base) heap_read_typed_compP [simp]:
  "heap_read_typed (compP f P) = heap_read_typed P"
by(intro ext)(simp add: heap_read_typed_def)

context J_JVM_heap_conf_base begin

definition if_bisimJ2JVM :: 
  "(('addr,'thread_id,status × 'addr expr×'addr locals,'heap,'addr) state, 
    ('addr,'thread_id,status × 'addr option × 'addr frame list,'heap,'addr) state) bisim"
where 
  "if_bisimJ2JVM = 
   FWbisimulation_base.mbisim red_red0.init_fin_bisim red_red0.init_fin_bisim_wait B
   FWbisimulation_base.mbisim red0_Red1'.init_fin_bisim red0_Red1'.init_fin_bisim_wait B
   if_mbisim_Red1'_Red1 B 
   FWbisimulation_base.mbisim Red1_execd.init_fin_bisim Red1_execd.init_fin_bisim_wait"

definition if_tlsimJ2JVM ::
  "('thread_id × ('addr, 'thread_id, status × 'addr expr × 'addr locals,
                  'heap, 'addr, ('addr, 'thread_id) obs_event action) thread_action,
    'thread_id × ('addr, 'thread_id, status × 'addr jvm_thread_state,
                  'heap, 'addr, ('addr, 'thread_id) obs_event action) thread_action) bisim"
where
  "if_tlsimJ2JVM = 
   FWbisimulation_base.mta_bisim red_red0.init_fin_bisim B 
   FWbisimulation_base.mta_bisim red0_Red1'.init_fin_bisim B (=) B 
   FWbisimulation_base.mta_bisim Red1_execd.init_fin_bisim"

end

sublocale J_JVM_conf_read < red_mthr: if_τmultithreaded_wf final_expr "mred P" convert_RA "τMOVE P"
by(unfold_locales)

sublocale J_JVM_conf_read < execd_mthr: 
  if_τmultithreaded_wf
    JVM_final
    "mexecd (compP2 (compP1 P))"
    convert_RA 
    "τMOVE2 (compP2 (compP1 P))"
by(unfold_locales)

context J_JVM_conf_read begin

theorem if_bisimJ2JVM_weak_bisim:
  assumes wf: "wf_J_prog P"
  shows "delay_bisimulation_diverge_final
    (red_mthr.mthr.if.redT P) (execd_mthr.mthr.if.redT (J2JVM P)) if_bisimJ2JVM if_tlsimJ2JVM 
    red_mthr.if.mτmove execd_mthr.if.mτmove red_mthr.mthr.if.mfinal execd_mthr.mthr.if.mfinal"
apply (simp only: if_bisimJ2JVM_def if_tlsimJ2JVM_def J2JVM_def o_apply)
apply(rule delay_bisimulation_diverge_final_compose)
 apply(rule FWdelay_bisimulation_diverge.mthr_delay_bisimulation_diverge_final)
 apply(rule FWdelay_bisimulation_diverge.init_fin_FWdelay_bisimulation_diverge)
 apply(rule red_red0_FWbisim[OF wf_prog_wwf_prog[OF wf]])
apply(rule delay_bisimulation_diverge_final_compose)
 apply(rule FWdelay_bisimulation_diverge.mthr_delay_bisimulation_diverge_final)
 apply(rule FWdelay_bisimulation_diverge.init_fin_FWdelay_bisimulation_diverge)
 apply(rule red0_Red1'_FWweak_bisim[OF wf])
apply(rule delay_bisimulation_diverge_final_compose)
 apply(rule delay_bisimulation_diverge_final.intro)
  apply(rule bisimulation_into_delay.delay_bisimulation)
  apply(rule if_Red1'_Red1_bisim_into_weak[OF compP1_pres_wf[OF wf]])
 apply(rule bisimulation_final.delay_bisimulation_final_base)
 apply(rule if_Red1'_Red1_bisimulation_final[OF compP1_pres_wf[OF wf]])
apply(rule FWdelay_bisimulation_diverge.mthr_delay_bisimulation_diverge_final)
apply(rule FWdelay_bisimulation_diverge.init_fin_FWdelay_bisimulation_diverge)
apply(rule Red1_exec1_FWwbisim[OF compP1_pres_wf[OF wf]])
done

lemma if_bisimJ2JVM_start:
  assumes wf: "wf_J_prog P"
  and wf_start: "wf_start_state P C M vs"
  shows "if_bisimJ2JVM (init_fin_lift_state Running (J_start_state P C M vs))
                       (init_fin_lift_state Running (JVM_start_state (J2JVM P) C M vs))"
using assms
unfolding if_bisimJ2JVM_def J2JVM_def o_apply
apply(intro bisim_composeI)
   apply(rule FWbisimulation_base.init_fin_lift_state_mbisimI)
   apply(erule (1) bisim_J_J0_start[OF wf_prog_wwf_prog])
  apply(rule FWbisimulation_base.init_fin_lift_state_mbisimI)
  apply(erule (1) bisim_J0_J1_start)
 apply(erule if_bisim_J1_J1_start[OF compP1_pres_wf])
 apply simp
apply(rule FWbisimulation_base.init_fin_lift_state_mbisimI)
apply(erule bisim_J1_JVM_start[OF compP1_pres_wf])
apply simp
done

lemma red_Runs_eq_mexecd_Runs:
  fixes C M vs
  defines s: "s  init_fin_lift_state Running (J_start_state P C M vs)"
  and comps: "cs  init_fin_lift_state Running (JVM_start_state (J2JVM P) C M vs)"
  assumes wf: "wf_J_prog P"
  and wf_start: "wf_start_state P C M vs"
  shows "red_mthr.mthr.if.ℰ P s = execd_mthr.mthr.if.ℰ (J2JVM P) cs"
proof -
  from wf wf_start have bisim: "if_bisimJ2JVM s cs"
    unfolding s comps by(rule if_bisimJ2JVM_start)

  interpret divfin: delay_bisimulation_diverge_final 
    "red_mthr.mthr.if.redT P" 
    "execd_mthr.mthr.if.redT (J2JVM P)"
    "if_bisimJ2JVM"
    "if_tlsimJ2JVM"
    "red_mthr.if.mτmove"
    "execd_mthr.if.mτmove"
    "red_mthr.mthr.if.mfinal"
    "execd_mthr.mthr.if.mfinal"
    using wf by(rule if_bisimJ2JVM_weak_bisim)
  
  show ?thesis (is "?lhs = ?rhs")
  proof(intro equalityI subsetI)
    fix E
    assume "E  ?lhs"
    then obtain E' where E: "E = lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) (llist_of_tllist E'))"
      and E': "red_mthr.if.mthr.τRuns s E'"
      unfolding red_mthr.if.ℰ_conv_Runs by blast
    from divfin.simulation_τRuns1[OF bisim E']
    obtain E'' where E'': "execd_mthr.if.mthr.τRuns cs E''"
      and tlsim: "tllist_all2 if_tlsimJ2JVM (option.rel_option if_bisimJ2JVM) E' E''"
      unfolding J2JVM_def o_apply by blast
    let ?E = "lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) (llist_of_tllist E''))"
    from tlsim have "llist_all2 if_tlsimJ2JVM (llist_of_tllist E') (llist_of_tllist E'')"
      by(rule tllist_all2D_llist_all2_llist_of_tllist)
    hence "llist_all2 (=) (lmap (λ(t, ta). llist_of (map (Pair t) tao)) (llist_of_tllist E'))
                             (lmap (λ(t, ta). llist_of (map (Pair t) tao)) (llist_of_tllist E''))"
      unfolding llist_all2_lmap1 llist_all2_lmap2
      by(rule llist_all2_mono)(auto simp add: if_tlsimJ2JVM_def FWbisimulation_base.mta_bisim_def ta_bisim_def)
    hence "?E = E" unfolding llist.rel_eq E by simp
    also from E'' have "?E  ?rhs" unfolding J2JVM_def o_apply execd_mthr.if.ℰ_conv_Runs by blast
    finally (subst) show "E  ?rhs" .
  next
    fix E
    assume "E  ?rhs"
    then obtain E' where E: "E = lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) (llist_of_tllist E'))"
      and E': "execd_mthr.if.mthr.τRuns cs E'"
      unfolding execd_mthr.if.ℰ_conv_Runs J2JVM_def o_apply by blast
    from divfin.simulation_τRuns2[OF bisim, simplified J2JVM_def o_apply, OF E']
    obtain E'' where E'': "red_mthr.if.mthr.τRuns s E''"
      and tlsim: "tllist_all2 if_tlsimJ2JVM (option.rel_option if_bisimJ2JVM) E'' E'" by blast
    let ?E = "lconcat (lmap (λ(t, ta). llist_of (map (Pair t) tao)) (llist_of_tllist E''))"
    from tlsim have "llist_all2 if_tlsimJ2JVM (llist_of_tllist E'') (llist_of_tllist E')"
      by(rule tllist_all2D_llist_all2_llist_of_tllist)
    hence "llist_all2 (=) (lmap (λ(t, ta). llist_of (map (Pair t) tao)) (llist_of_tllist E''))
                             (lmap (λ(t, ta). llist_of (map (Pair t) tao)) (llist_of_tllist E'))"
      unfolding llist_all2_lmap1 llist_all2_lmap2
      by(rule llist_all2_mono)(auto simp add: if_tlsimJ2JVM_def FWbisimulation_base.mta_bisim_def ta_bisim_def)
    hence "?E = E" unfolding llist.rel_eq E by simp
    also from E'' have "?E  ?lhs" unfolding red_mthr.if.ℰ_conv_Runs by blast
    finally (subst) show "E  ?lhs" .
  qed
qed

lemma red_ℰ_eq_mexecd_ℰ:
  " wf_J_prog P; wf_start_state P C M vs 
   J_ℰ P C M vs Running = JVMd_ℰ (J2JVM P) C M vs Running"
by(simp only: red_Runs_eq_mexecd_Runs)

theorem J2JVM_jmm_correct:
  assumes wf: "wf_J_prog P"
  and wf_start: "wf_start_state P C M vs"
  shows "legal_execution P (J_ℰ P C M vs Running) (E, ws)  
         legal_execution (J2JVM P) (JVMd_ℰ (J2JVM P) C M vs Running) (E, ws)"
by(simp only: red_ℰ_eq_mexecd_ℰ[OF assms] J2JVM_def o_apply compP1_def compP2_def legal_execution_compP)

theorem J2JVM_jmm_correct_weak:
  assumes wf: "wf_J_prog P"
  and wf_start: "wf_start_state P C M vs"
  shows "weakly_legal_execution P (J_ℰ P C M vs Running) (E, ws)  
         weakly_legal_execution (J2JVM P) (JVMd_ℰ (J2JVM P) C M vs Running) (E, ws)"
by(simp only: red_ℰ_eq_mexecd_ℰ[OF assms] J2JVM_def o_apply compP1_def compP2_def weakly_legal_execution_compP)

theorem J2JVM_jmm_correctly_synchronized:
  assumes wf: "wf_J_prog P"
  and wf_start: "wf_start_state P C M vs"
  shows "correctly_synchronized (J2JVM P) (JVMd_ℰ (J2JVM P) C M vs Running)  
         correctly_synchronized P (J_ℰ P C M vs Running)"
by(simp only: red_ℰ_eq_mexecd_ℰ[OF assms] J2JVM_def o_apply compP1_def compP2_def correctly_synchronized_compP)

end

end

Theory JMM_Type2

(*  Title:      JinjaThreads/MM/JMM_Type2.thy
    Author:     Andreas Lochbihler
*)

section ‹JMM heap implementation 2›

theory JMM_Type2
imports 
  "../Common/ExternalCallWF"
  "../Common/ConformThreaded"
  JMM_Heap
begin

subsection ‹Definitions›

datatype addr = Address htype nat   ― ‹heap type and sequence number›

lemma rec_addr_conv_case_addr [simp]: "rec_addr = case_addr"
by(auto intro!: ext split: addr.split)

instantiation addr :: addr begin
definition "hash_addr (a :: addr) = (case a of Address ht n  int n)"
definition "monitor_finfun_to_list (ls :: addr ⇒f nat) = (SOME xs. set xs = {x. finfun_dom ls $ x })"
instance
proof
  fix ls :: "addr ⇒f nat"
  show "set (monitor_finfun_to_list ls) = Collect (($) (finfun_dom ls))"
    unfolding monitor_finfun_to_list_addr_def
    using finite_list[OF finite_finfun_dom, where ?f.1 = "ls"]
    by(rule someI_ex)
qed
end

primrec the_Address :: "addr  htype × nat"
where "the_Address (Address hT n) = (hT, n)"

text ‹
  The JMM heap only stores which sequence numbers of a given @{typ "htype"} have already been allocated.
›

type_synonym JMM_heap = "htype  nat set"

translations (type) "JMM_heap" <= (type) "htype  nat set"

definition jmm_allocate :: "JMM_heap  htype  (JMM_heap × addr) set"
where "jmm_allocate h hT = (let hhT = h hT in (λn. (h(hT := insert n hhT), Address hT n)) ` (- hhT))"

abbreviation jmm_empty :: "JMM_heap" where "jmm_empty == (λ_. {})"

definition jmm_typeof_addr :: "'m prog  JMM_heap  addr  htype"
where "jmm_typeof_addr P h = (λhT. if is_htype P hT then Some hT else None)  fst  the_Address"

definition jmm_typeof_addr' :: "'m prog  addr  htype"
where "jmm_typeof_addr' P = (λhT. if is_htype P hT then Some hT else None)  fst  the_Address"

lemma jmm_typeof_addr'_conv_jmm_type_addr: "jmm_typeof_addr' P = jmm_typeof_addr P h"
by(simp add: jmm_typeof_addr_def jmm_typeof_addr'_def)

lemma jmm_typeof_addr'_conv_jmm_typeof_addr: "(λ_. jmm_typeof_addr' P) = jmm_typeof_addr P"
by(simp add: jmm_typeof_addr_def jmm_typeof_addr'_def fun_eq_iff)

lemma jmm_typeof_addr_conv_jmm_typeof_addr': "jmm_typeof_addr = (λP _. jmm_typeof_addr' P)"
by(simp add: jmm_typeof_addr'_conv_jmm_typeof_addr)

definition jmm_heap_read :: "JMM_heap  addr  addr_loc  addr val  bool"
where "jmm_heap_read h a ad v = True"

context
  notes [[inductive_internals]]
begin

inductive jmm_heap_write :: "JMM_heap  addr  addr_loc  addr val  JMM_heap  bool"
where "jmm_heap_write h a ad v h"

end

definition jmm_hconf :: "JMM_heap  bool"
where "jmm_hconf h  True"

definition jmm_allocated :: "JMM_heap  addr set"
where "jmm_allocated h = {Address CTn n|CTn n. n  h CTn}"

definition jmm_spurious_wakeups :: "bool"
where "jmm_spurious_wakeups = True"

lemmas jmm_heap_ops_defs =
  jmm_allocate_def jmm_typeof_addr_def 
  jmm_heap_read_def jmm_heap_write_def
  jmm_allocated_def jmm_spurious_wakeups_def

type_synonym thread_id = "addr"

abbreviation (input) addr2thread_id :: "addr  thread_id"
where "addr2thread_id  λx. x"

abbreviation (input) thread_id2addr :: "thread_id  addr"
where "thread_id2addr  λx. x"

interpretation jmm: heap_base
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" jmm_heap_read jmm_heap_write
  for P
.

abbreviation jmm_hext :: "'m prog  JMM_heap  JMM_heap  bool" ("_  _ ⊴jmm _" [51,51,51] 50)
where "jmm_hext  jmm.hext TYPE('m)"

abbreviation jmm_conf :: "'m prog  JMM_heap  addr val  ty  bool" 
  ("_,_ ⊢jmm _ :≤ _"  [51,51,51,51] 50)
where "jmm_conf P  jmm.conf TYPE('m) P P"

abbreviation jmm_addr_loc_type :: "'m prog  JMM_heap  addr  addr_loc  ty  bool" 
  ("_,_ ⊢jmm _@_ : _" [50, 50, 50, 50, 50] 51)
where "jmm_addr_loc_type P  jmm.addr_loc_type TYPE('m) P P"

abbreviation jmm_confs :: "'m prog  JMM_heap  addr val list  ty list  bool"
  ("_,_ ⊢jmm _ [:≤] _"  [51,51,51,51] 50)
where "jmm_confs P  jmm.confs TYPE('m) P P"

abbreviation jmm_tconf :: "'m prog  JMM_heap  addr  bool" ("_,_ ⊢jmm _ √t" [51,51,51] 50)
where "jmm_tconf P  jmm.tconf TYPE('m) P P"

interpretation jmm: allocated_heap_base
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" jmm_heap_read jmm_heap_write
  jmm_allocated
  for P
.

text ‹Now a variation of the JMM with a different read operation that permits to read only type-conformant values›

abbreviation jmm_heap_read_typed :: "'m prog  JMM_heap  addr  addr_loc  addr val  bool"
where "jmm_heap_read_typed P  jmm.heap_read_typed TYPE('m) P P"

interpretation jmm': heap_base
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" "jmm_heap_read_typed P" jmm_heap_write
  for P .

abbreviation jmm'_hext :: "'m prog  JMM_heap  JMM_heap  bool" ("_  _ ⊴jmm'' _" [51,51,51] 50)
where "jmm'_hext  jmm'.hext TYPE('m)"

abbreviation jmm'_conf :: "'m prog  JMM_heap  addr val  ty  bool" 
  ("_,_ ⊢jmm'' _ :≤ _"  [51,51,51,51] 50)
where "jmm'_conf P  jmm'.conf TYPE('m) P P"

abbreviation jmm'_addr_loc_type :: "'m prog  JMM_heap  addr  addr_loc  ty  bool" 
  ("_,_ ⊢jmm'' _@_ : _" [50, 50, 50, 50, 50] 51)
where "jmm'_addr_loc_type P  jmm'.addr_loc_type TYPE('m) P P"

abbreviation jmm'_confs :: "'m prog  JMM_heap  addr val list  ty list  bool"
  ("_,_ ⊢jmm'' _ [:≤] _"  [51,51,51,51] 50)
where "jmm'_confs P  jmm'.confs TYPE('m) P P"

abbreviation jmm'_tconf :: "'m prog  JMM_heap  addr  bool" ("_,_ ⊢jmm'' _ √t" [51,51,51] 50)
where "jmm'_tconf P  jmm'.tconf TYPE('m) P P"

subsection ‹Heap locale interpretations›

subsection ‹Locale heap›

lemma jmm_heap: "heap addr2thread_id thread_id2addr jmm_allocate (jmm_typeof_addr P) jmm_heap_write P"
proof
  fix h' a h hT
  assume "(h', a)  jmm_allocate h hT" "is_htype P hT"
  thus "jmm_typeof_addr P h' a = hT"
    by(auto simp add: jmm_heap_ops_defs)
next
  fix h hT h' a
  assume "(h', a)  jmm_allocate h hT"
  thus "P  h ⊴jmm h'" by(auto simp add: jmm_heap_ops_defs intro: jmm.hextI)
next
  fix h a al v h'
  assume "jmm_heap_write h a al v h'"
  thus "P  h ⊴jmm h'" by cases auto
qed simp

interpretation jmm: heap
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" jmm_heap_read jmm_heap_write
  P
  for P
by(rule jmm_heap)

declare jmm.typeof_addr_thread_id2_addr_addr2thread_id [simp del]

lemmas jmm'_heap = jmm_heap

interpretation jmm': heap
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" "jmm_heap_read_typed P" jmm_heap_write
  P
  for P
by(rule jmm'_heap)

declare jmm'.typeof_addr_thread_id2_addr_addr2thread_id [simp del]

lemma jmm_heap_read_typed_default_val:
  "heap_base.heap_read_typed typeof_addr jmm_heap_read P h a al
   (default_val (THE T. heap_base.addr_loc_type typeof_addr P h a al T))"
by(rule heap_base.heap_read_typedI)(simp_all add: heap_base.THE_addr_loc_type jmm_heap_read_def heap_base.defval_conf)

lemma jmm_allocate_Eps:
  "(SOME ha. ha  jmm_allocate h hT) = (h', a')
   jmm_allocate h hT  {}  (h', a')  jmm_allocate h hT"
by(auto dest: jmm.allocate_Eps)

lemma jmm_allocate_eq_empty: "jmm_allocate h hT = {}  h hT = UNIV"
by(auto simp add: jmm_allocate_def)

lemma jmm_allocate_otherD:
  "(h', a)  jmm_allocate h hT  hT'. hT'  hT  h' hT' = h hT'"
by(auto simp add: jmm_allocate_def)

lemma jmm_start_heap_ok: "jmm.start_heap_ok"
apply(simp add: jmm.start_heap_ok_def jmm.start_heap_data_def initialization_list_def sys_xcpts_list_def jmm.create_initial_object_simps)
apply(split prod.split, clarify, clarsimp simp add: jmm.create_initial_object_simps jmm_allocate_eq_empty Thread_neq_sys_xcpts sys_xcpts_neqs dest!: jmm_allocate_Eps jmm_allocate_otherD)+
done

subsection ‹Locale heap_conf›

interpretation jmm: heap_conf_base
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" jmm_heap_read jmm_heap_write jmm_hconf
  P
  for P .

abbreviation (input) jmm'_hconf :: "JMM_heap  bool"
where "jmm'_hconf == jmm_hconf"

interpretation jmm': heap_conf_base
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" "jmm_heap_read_typed P" jmm_heap_write jmm'_hconf
  P
  for P .

abbreviation jmm_heap_read_typeable :: "'m prog  bool"
where "jmm_heap_read_typeable P  jmm.heap_read_typeable TYPE('m) P jmm_hconf P"

abbreviation jmm'_heap_read_typeable :: "'m prog  bool"
where "jmm'_heap_read_typeable P  jmm'.heap_read_typeable TYPE('m) P jmm_hconf P"

lemma jmm_heap_read_typeable: "jmm_heap_read_typeable P"
by(rule jmm.heap_read_typeableI)(simp add: jmm_heap_read_def)

lemma jmm'_heap_read_typeable: "jmm'_heap_read_typeable P"
by(rule jmm'.heap_read_typeableI)(auto simp add: jmm_heap_read_def jmm.heap_read_typed_def dest: jmm'.addr_loc_type_fun)

lemma jmm_heap_conf:
  "heap_conf addr2thread_id thread_id2addr jmm_empty jmm_allocate (jmm_typeof_addr P) jmm_heap_write jmm_hconf P"
by(unfold_locales)(simp_all add: jmm_hconf_def jmm_heap_ops_defs split: if_split_asm)

interpretation jmm: heap_conf
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" jmm_heap_read jmm_heap_write jmm_hconf
  P
  for P
by(rule jmm_heap_conf)

lemmas jmm'_heap_conf = jmm_heap_conf

interpretation jmm': heap_conf
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" "jmm_heap_read_typed P" jmm_heap_write jmm'_hconf
  P
  for P
by(rule jmm'_heap_conf)

subsection ‹Locale heap_progress›

lemma jmm_heap_progress:
  "heap_progress addr2thread_id thread_id2addr jmm_empty jmm_allocate (jmm_typeof_addr P) jmm_heap_read jmm_heap_write jmm_hconf P"
proof
  fix h a al T
  assume "jmm_hconf h"
    and al: "P,h ⊢jmm a@al : T"
  show "v. jmm_heap_read h a al v  P,h ⊢jmm v :≤ T"
    using jmm.defval_conf[of P P h T] unfolding jmm_heap_ops_defs by blast
next
  fix h a al T v
  assume "P,h ⊢jmm a@al : T"
  show "h'. jmm_heap_write h a al v h'"
    by(auto intro: jmm_heap_write.intros)
qed

interpretation jmm: heap_progress
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" jmm_heap_read jmm_heap_write jmm_hconf
  P
  for P
by(rule jmm_heap_progress)

lemma jmm'_heap_progress:
  "heap_progress addr2thread_id thread_id2addr jmm_empty jmm_allocate (jmm_typeof_addr P) (jmm_heap_read_typed P) jmm_heap_write jmm'_hconf P"
proof
  fix h a al T
  assume "jmm'_hconf h"
    and al: "P,h ⊢jmm' a@al : T"
  thus "v. jmm_heap_read_typed P h a al v  P,h ⊢jmm' v :≤ T"
    unfolding jmm_heap_read_def jmm.heap_read_typed_def
    by(blast dest: jmm'.addr_loc_type_fun intro: jmm'.defval_conf)+
next
  fix h a al T v
  assume "P,h ⊢jmm' a@al : T"
    and "P,h ⊢jmm' v :≤ T"
  thus "h'. jmm_heap_write h a al v h'"
    by(auto intro: jmm_heap_write.intros)
qed

interpretation jmm': heap_progress
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" "jmm_heap_read_typed P" jmm_heap_write jmm'_hconf
  P
  for P
by(rule jmm'_heap_progress)

subsection ‹Locale heap_conf_read›

lemma jmm'_heap_conf_read:
  "heap_conf_read addr2thread_id thread_id2addr jmm_empty jmm_allocate (jmm_typeof_addr P) (jmm_heap_read_typed P) jmm_heap_write jmm'_hconf P"
by(rule jmm.heap_conf_read_heap_read_typed)

interpretation jmm': heap_conf_read
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" "jmm_heap_read_typed P" jmm_heap_write jmm'_hconf
  P
  for P
by(rule jmm'_heap_conf_read)

interpretation jmm': heap_typesafe
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" "jmm_heap_read_typed P" jmm_heap_write jmm'_hconf
  P
  for P
..

subsection ‹Locale allocated_heap›

lemma jmm_allocated_heap:
  "allocated_heap addr2thread_id thread_id2addr jmm_empty jmm_allocate (jmm_typeof_addr P) jmm_heap_write jmm_allocated P"
proof
  show "jmm_allocated jmm_empty = {}" by(simp add: jmm_allocated_def)
next
  fix h' a h hT
  assume "(h', a)  jmm_allocate h hT"
  thus "jmm_allocated h' = insert a (jmm_allocated h)  a  jmm_allocated h"
    by(auto simp add: jmm_heap_ops_defs split: if_split_asm)
next
  fix h a al v h'
  assume "jmm_heap_write h a al v h'"
  thus "jmm_allocated h' = jmm_allocated h" by cases simp
qed

interpretation jmm: allocated_heap
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" jmm_heap_read jmm_heap_write
  jmm_allocated
  P
  for P
by(rule jmm_allocated_heap)

lemmas jmm'_allocated_heap = jmm_allocated_heap

interpretation jmm': allocated_heap
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" "jmm_heap_read_typed P" jmm_heap_write
  jmm_allocated
  P
  for P
by(rule jmm'_allocated_heap)

subsection ‹Syntax translations›

notation jmm'.external_WT' ("_,_ ⊢jmm'' (__'(_')) : _" [50,0,0,0,50] 60)

abbreviation jmm'_red_external :: 
  "'m prog  thread_id  JMM_heap  addr  mname  addr val list
   (addr, thread_id, JMM_heap) external_thread_action 
   addr extCallRet  JMM_heap  bool"
where "jmm'_red_external P  jmm'.red_external (TYPE('m)) P P"

abbreviation jmm'_red_external_syntax :: 
  "'m prog  thread_id  addr  mname  addr val list  JMM_heap
   (addr, thread_id, JMM_heap) external_thread_action 
   addr extCallRet  JMM_heap  bool"
  ("_,_ ⊢jmm'' ((__'(_')),/_) -_→ext ((_),/(_))" [50, 0, 0, 0, 0, 0, 0, 0, 0] 51)
where
  "P,t ⊢jmm' aM(vs), h -ta→ext va, h'  jmm'_red_external P t h a M vs ta va h'"

abbreviation jmm'_red_external_aggr :: 
  "'m prog  thread_id  addr  mname  addr val list  JMM_heap 
     ((addr, thread_id, JMM_heap) external_thread_action × addr extCallRet × JMM_heap) set"
where "jmm'_red_external_aggr P  jmm'.red_external_aggr TYPE('m) P P"

abbreviation jmm'_heap_copy_loc :: 
  "'m prog  addr  addr  addr_loc  JMM_heap
   (addr, thread_id) obs_event list  JMM_heap  bool"
where "jmm'_heap_copy_loc  jmm'.heap_copy_loc TYPE('m)"

abbreviation jmm'_heap_copies :: 
  "'m prog  addr  addr  addr_loc list  JMM_heap
   (addr, thread_id) obs_event list  JMM_heap  bool"
where "jmm'_heap_copies  jmm'.heap_copies TYPE('m)"

abbreviation jmm'_heap_clone ::
  "'m prog  JMM_heap  addr  JMM_heap
   ((addr, thread_id) obs_event list × addr) option  bool"
where "jmm'_heap_clone P  jmm'.heap_clone TYPE('m) P P"

end

Theory JMM_Interp

(*  Title:      JinjaThreads/MM/JMM_Interp.thy
    Author:     Andreas Lochbihler

    Interpret the language specific heap locales with the Java memory model
*)

theory JMM_Interp imports
  JMM_Compiler
  "../J/Deadlocked"
  "../BV/JVMDeadlocked"
  JMM_Type2
  DRF_J
  DRF_JVM
begin

lemma jmm'_J_typesafe:
  "J_typesafe addr2thread_id thread_id2addr jmm_empty jmm_allocate (jmm_typeof_addr P) (jmm_heap_read_typed P) jmm_heap_write jmm_hconf P"
by unfold_locales

lemma jmm'_JVM_typesafe:
  "JVM_typesafe addr2thread_id thread_id2addr jmm_empty jmm_allocate (jmm_typeof_addr P) (jmm_heap_read_typed P) jmm_heap_write jmm_hconf P"
by unfold_locales

lemma jmm_typeof_addr_compP [simp]:
  "jmm_typeof_addr (compP f P) = jmm_typeof_addr P"
by(simp add: jmm_typeof_addr_def fun_eq_iff)

lemma compP2_compP1_convs:
  "is_type (compP2 (compP1 P)) = is_type P"
  "is_class (compP2 (compP1 P)) = is_class P"
  "jmm'_addr_loc_type (compP2 (compP1 P)) = jmm'_addr_loc_type P"
  "jmm'_conf (compP2 (compP1 P)) = jmm'_conf P"
by(simp_all add: compP2_def heap_base.compP_conf heap_base.compP_addr_loc_type fun_eq_iff split: addr_loc.splits)

lemma jmm'_J_JVM_conf_read:
  "J_JVM_conf_read addr2thread_id thread_id2addr jmm_empty jmm_allocate (jmm_typeof_addr P) (jmm_heap_read_typed P) jmm_heap_write jmm_hconf P"
apply(rule J_JVM_conf_read.intro)
apply(rule J1_JVM_conf_read.intro)
apply(rule JVM_conf_read.intro)
 prefer 2
 apply(rule JVM_heap_conf.intro)
 apply(rule JVM_heap_conf_base'.intro)
 apply(unfold compP2_def compP1_def compP_heap compP_heap_conf compP_heap_conf_read jmm_typeof_addr_compP)
 apply unfold_locales
done

lemma jmm_J_allocated_progress:
  "J_allocated_progress addr2thread_id thread_id2addr jmm_empty jmm_allocate (jmm_typeof_addr P) jmm_heap_read jmm_heap_write jmm_hconf jmm_allocated P"
by unfold_locales

lemma jmm'_J_allocated_progress:
  "J_allocated_progress addr2thread_id thread_id2addr jmm_empty jmm_allocate (jmm_typeof_addr P) (jmm_heap_read_typed P) jmm_heap_write jmm_hconf jmm_allocated P"
by(unfold_locales)

lemma jmm_JVM_allocated_progress:
  "JVM_allocated_progress addr2thread_id thread_id2addr jmm_empty jmm_allocate (jmm_typeof_addr P) jmm_heap_read jmm_heap_write jmm_hconf jmm_allocated P"
by unfold_locales

lemma jmm'_JVM_allocated_progress:
  "JVM_allocated_progress addr2thread_id thread_id2addr jmm_empty jmm_allocate (jmm_typeof_addr P) (jmm_heap_read_typed P) jmm_heap_write jmm_hconf jmm_allocated P"
by(unfold_locales)

end

Theory JMM_Typesafe2

(*  Title:      JinjaThreads/MM/JMM_Typesafe2.thy
    Author:     Andreas Lochbihler
*)

section ‹Specialize type safety for JMM heap implementation 2›

theory JMM_Typesafe2
imports
  JMM_Type2
  JMM_Common
begin

interpretation jmm: heap'
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr' P" jmm_heap_read jmm_heap_write
  for P
by(rule heap'.intro)(unfold jmm_typeof_addr'_conv_jmm_typeof_addr, unfold_locales)

abbreviation jmm_addr_loc_type' :: "'m prog  addr  addr_loc  ty  bool" ("_ ⊢jmm _@_ : _" [50, 50, 50, 50] 51)
  where "jmm_addr_loc_type' P  jmm.addr_loc_type TYPE('m) P P"

lemma jmm_addr_loc_type_conv_jmm_addr_loc_type' [simp, heap_independent]:
  "jmm_addr_loc_type P h = jmm_addr_loc_type' P"
by(metis jmm_typeof_addr'_conv_jmm_typeof_addr heap_base'.addr_loc_type_conv_addr_loc_type)

abbreviation jmm_conf' :: "'m prog  addr val  ty  bool" ("_ ⊢jmm _ :≤ _"  [51,51,51] 50)
  where "jmm_conf' P  jmm.conf TYPE('m) P P"

lemma jmm_conf_conv_jmm_conf' [simp, heap_independent]:
  "jmm_conf P h = jmm_conf' P"
by (metis jmm_typeof_addr'_conv_jmm_typeof_addr heap_base'.conf_conv_conf)

lemma jmm_heap'': "heap'' addr2thread_id thread_id2addr jmm_allocate (jmm_typeof_addr' P) jmm_heap_write P"
by(unfold_locales)(auto simp add: jmm_typeof_addr'_def jmm_allocate_def split: if_split_asm)

interpretation jmm: heap''
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr' P" jmm_heap_read jmm_heap_write
  for P
by(rule jmm_heap'')

interpretation jmm': heap''
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr' P" "jmm_heap_read_typed P" jmm_heap_write
  for P
by(rule jmm_heap'')

abbreviation jmm_wf_start_state :: "'m prog  cname  mname  addr val list  bool"
  where "jmm_wf_start_state P  jmm.wf_start_state TYPE('m) P P"


abbreviation if_heap_read_typed ::
  "('x  bool)  ('l, 't, 'x, 'heap, 'w, ('addr :: addr, 'thread_id) obs_event) semantics
    ('addr  htype option)
    'm prog  ('l, 't, status × 'x, 'heap, 'w, ('addr, 'thread_id) obs_event action) semantics"
where
  "final. if_heap_read_typed final r typeof_addr P t xh ta x'h' 
   multithreaded_base.init_fin final r t xh ta x'h' 
  (ad al v T. NormalAction (ReadMem ad al v)  set tao  heap_base'.addr_loc_type TYPE('heap) typeof_addr P ad al T  heap_base'.conf TYPE('heap) typeof_addr P v T)"

lemma if_mthr_Runs_heap_read_typedI:
  fixes final and r :: "('addr, 't, 'x, 'heap, 'w, ('addr :: addr, 'thread_id) obs_event) semantics"
  assumes "trsys.Runs (multithreaded_base.redT (final_thread.init_fin_final final) (multithreaded_base.init_fin final r) (map NormalAction  convert_RA)) s ξ"
  (is "trsys.Runs ?redT _ _")
  and "ad al v T.  NormalAction (ReadMem ad al v)  lset (lconcat (lmap (llist_of  obs_a  snd) ξ)); heap_base'.addr_loc_type TYPE('heap) typeof_addr P ad al T   heap_base'.conf TYPE('heap) typeof_addr P v T"
  (is "ad al v T.  ?obs ξ ad al v; ?adal ad al T   ?conf v T")
  shows "trsys.Runs (multithreaded_base.redT (final_thread.init_fin_final final) (if_heap_read_typed final r typeof_addr P) (map NormalAction  convert_RA)) s ξ"
  (is "trsys.Runs ?redT' _ _")
using assms
proof(coinduction arbitrary: s ξ rule: trsys.Runs.coinduct[consumes 1, case_names Runs, case_conclusion Runs Stuck Step])
  case (Runs s ξ)
  let ?read = "λξ. (ad al v T. ?obs ξ ad al v  ?adal ad al T  ?conf v T)"
  note read = Runs(2)
  from Runs(1) show ?case
  proof(cases rule: trsys.Runs.cases[consumes 1, case_names Stuck Step])
    case (Stuck S)
    { fix tta s'
      from ¬ ?redT S tta s' have "¬ ?redT' S tta s'"
        by(rule contrapos_nn)(fastforce simp add: multithreaded_base.redT.simps) }
    hence ?Stuck using ξ = LNil› unfolding s = S by blast
    thus ?thesis ..
  next
    case (Step S s' ttas tta)
    from ξ = LCons tta ttas read
    have read1: "ad al v T.  NormalAction (ReadMem ad al v)  set snd ttao; ?adal ad al T   ?conf v T"
      and read2: "?read ttas" by(auto simp add: o_def)
    from ?redT S tta s' read1
    have "?redT' S tta s'" by(fastforce simp add: multithreaded_base.redT.simps)
    hence ?Step using Step read2 s = S by blast
    thus ?thesis ..
  qed
qed

lemma if_mthr_Runs_heap_read_typedD:
  fixes final and r :: "('addr, 't, 'x, 'heap, 'w, ('addr :: addr, 'thread_id) obs_event) semantics"
  assumes Runs': "trsys.Runs (multithreaded_base.redT (final_thread.init_fin_final final) (if_heap_read_typed final r typeof_addr P) (map NormalAction  convert_RA)) s ξ"
  (is "?Runs' s ξ")
  and stuck: "ttas s' tta s''. 
    multithreaded_base.RedT (final_thread.init_fin_final final) (if_heap_read_typed final r typeof_addr P) (map NormalAction  convert_RA) s ttas s';
    multithreaded_base.redT (final_thread.init_fin_final final) (multithreaded_base.init_fin final r) (map NormalAction  convert_RA) s' tta s'' 
   tta s''. multithreaded_base.redT (final_thread.init_fin_final final) (if_heap_read_typed final r typeof_addr P) (map NormalAction  convert_RA) s' tta s''"
  (is "ttas s' tta s''.  ?RedT' s ttas s'; ?redT s' tta s''   tta s''. ?redT' s' tta s''")
  shows "trsys.Runs (multithreaded_base.redT (final_thread.init_fin_final final) (multithreaded_base.init_fin final r) (map NormalAction  convert_RA)) s ξ"
  (is "?Runs s ξ")
proof -
  define s' where "s' = s"
  with Runs' have "ttas. ?RedT' s ttas s'  ?Runs' s' ξ"
    by(auto simp add: multithreaded_base.RedT_def o_def)
  thus "?Runs s' ξ"
  proof(coinduct rule: trsys.Runs.coinduct[consumes 1, case_names Runs, case_conclusion Runs Stuck Step])
    case (Runs s' ξ)
    then obtain ttas where RedT': "?RedT' s ttas s'"
      and Runs': "?Runs' s' ξ" by blast
    from Runs' show ?case
    proof(cases rule: trsys.Runs.cases[consumes 1, case_names Stuck Step])
      case (Stuck S)
      have "tta s''. ¬ ?redT s' tta s''"
      proof
        fix tta s''
        assume "?redT s' tta s''"
        from stuck[OF RedT' this] 
        obtain tta s'' where "?redT' s' tta s''" by blast
        with Stuck(3)[of tta s''] show False
          unfolding s' = S by contradiction
      qed
      with Stuck(1-2) have ?Stuck by simp
      thus ?thesis by(rule disjI1)
    next
      case (Step S s'' ξ' tta)
      note Step = Step(2-)[folded s' = S]
      from ?redT' s' tta s'' have "?redT s' tta s''"
        by(fastforce simp add: multithreaded_base.redT.simps)
      moreover from RedT' ?redT' s' tta s''
      have "?RedT' s (ttas @ [tta]) s''"
        unfolding multithreaded_base.RedT_def by(rule rtrancl3p_step)
      ultimately have ?Step using ξ = LCons tta ξ' ?Runs' s'' ξ' by blast
      thus ?thesis by(rule disjI2)
    qed
  qed
qed

lemma heap_copy_loc_heap_read_typed:
  "heap_base.heap_copy_loc (heap_base.heap_read_typed (λ_ :: 'heap. typeof_addr) heap_read P) heap_write a a' al h obs h' 
  heap_base.heap_copy_loc heap_read heap_write a a' al h obs h' 
  (ad al v T. ReadMem ad al v  set obs  heap_base'.addr_loc_type TYPE('heap) typeof_addr P ad al T  heap_base'.conf TYPE('heap) typeof_addr P v T)"
by(auto elim!: heap_base.heap_copy_loc.cases intro!: heap_base.heap_copy_loc.intros dest: heap_base.heap_read_typed_into_heap_read heap_base.heap_read_typed_typed intro: heap_base.heap_read_typedI simp add: heap_base'.addr_loc_type_conv_addr_loc_type heap_base'.conf_conv_conf)

lemma heap_copies_heap_read_typed:
  "heap_base.heap_copies (heap_base.heap_read_typed (λ_ :: 'heap. typeof_addr) heap_read P) heap_write a a' als h obs h' 
  heap_base.heap_copies heap_read heap_write a a' als h obs h' 
  (ad al v T. ReadMem ad al v  set obs  heap_base'.addr_loc_type TYPE('heap) typeof_addr P ad al T  heap_base'.conf TYPE('heap) typeof_addr P v T)"
  (is "?lhs  ?rhs")
proof
  assume ?lhs thus ?rhs
    by(induct rule: heap_base.heap_copies.induct[consumes 1])(auto intro!: heap_base.heap_copies.intros simp add: heap_copy_loc_heap_read_typed)
next
  assume ?rhs thus ?lhs
    by(rule conjE)(induct rule: heap_base.heap_copies.induct[consumes 1], auto intro!: heap_base.heap_copies.intros simp add: heap_copy_loc_heap_read_typed)
qed

lemma heap_clone_heap_read_typed:
  "heap_base.heap_clone allocate (λ_ :: 'heap. typeof_addr) (heap_base.heap_read_typed (λ_ :: 'heap. typeof_addr) heap_read P) heap_write P a h h' obs 
  heap_base.heap_clone allocate (λ_ :: 'heap. typeof_addr) heap_read heap_write P a h h' obs 
  (ad al v T obs' a'. obs = (obs', a')  ReadMem ad al v  set obs'  heap_base'.addr_loc_type TYPE('heap) typeof_addr P ad al T  heap_base'.conf TYPE('heap) typeof_addr P v T)"
by(auto elim!: heap_base.heap_clone.cases intro: heap_base.heap_clone.intros simp add: heap_copies_heap_read_typed)

lemma red_external_heap_read_typed:
  "heap_base.red_external addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate (λ_ :: 'heap. typeof_addr) (heap_base.heap_read_typed (λ_ :: 'heap. typeof_addr) heap_read P) heap_write P t h a M vs ta va h' 
   heap_base.red_external addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate (λ_ :: 'heap. typeof_addr) heap_read heap_write P t h a M vs ta va h' 
  (ad al v T obs' a'. ReadMem ad al v  set tao  heap_base'.addr_loc_type TYPE('heap) typeof_addr P ad al T  heap_base'.conf TYPE('heap) typeof_addr P v T)"
by(auto elim!: heap_base.red_external.cases intro: heap_base.red_external.intros simp add: heap_clone_heap_read_typed)

lemma red_external_aggr_heap_read_typed:
  "(ta, va, h')  heap_base.red_external_aggr addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate (λ_ :: 'heap. typeof_addr) (heap_base.heap_read_typed (λ_ :: 'heap. typeof_addr) heap_read P) heap_write P t h a M vs 
   (ta, va, h')  heap_base.red_external_aggr addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate (λ_ :: 'heap. typeof_addr) heap_read heap_write P t h a M vs 
  (ad al v T obs' a'. ReadMem ad al v  set tao  heap_base'.addr_loc_type TYPE('heap) typeof_addr P ad al T  heap_base'.conf TYPE('heap) typeof_addr P v T)"
by(auto simp add: heap_base.red_external_aggr_def heap_clone_heap_read_typed split del: if_split split: if_split_asm)



lemma jmm'_heap_copy_locI: 
  "obs h'. heap_base.heap_copy_loc (heap_base.heap_read_typed typeof_addr jmm_heap_read P) jmm_heap_write a a' al h obs h'"
by(auto intro!: heap_base.heap_copy_loc.intros jmm_heap_read_typed_default_val intro: jmm_heap_write.intros)

lemma jmm'_heap_copiesI:
  "obs :: (addr, 'thread_id) obs_event list.
   h'. heap_base.heap_copies (heap_base.heap_read_typed typeof_addr jmm_heap_read P) jmm_heap_write a a' als h obs h'"
proof(induction als arbitrary: h)
  case Nil
  thus ?case by(blast intro: heap_base.heap_copies.intros)
next
  case (Cons al als)
  from jmm'_heap_copy_locI[of typeof_addr P a a' al h]
  obtain ob :: "(addr, 'thread_id) obs_event list" and h'
    where "heap_base.heap_copy_loc (heap_base.heap_read_typed typeof_addr jmm_heap_read P) jmm_heap_write a a' al h ob h'" 
    by blast
  with Cons.IH[of h'] show ?case
    by(auto 4 4 intro: heap_base.heap_copies.intros)
qed

lemma jmm'_heap_cloneI:
  fixes obsa :: "((addr, 'thread_id) obs_event list × addr) option"
  assumes "heap_base.heap_clone allocate typeof_addr jmm_heap_read jmm_heap_write P h a h' obsa"
  shows "h'. obsa :: ((addr, 'thread_id) obs_event list × addr) option. 
       heap_base.heap_clone allocate typeof_addr (heap_base.heap_read_typed typeof_addr jmm_heap_read P) jmm_heap_write P h a h' obsa"
using assms
proof(cases rule: heap_base.heap_clone.cases[consumes 1, case_names Fail Obj Arr])
  case Fail
  thus ?thesis by(blast intro: heap_base.heap_clone.intros)
next
  case (Obj C h' a' FDTs obs h'')
  with jmm'_heap_copiesI[of typeof_addr P a a' "map (λ((F, D), Tfm). CField D F) FDTs" h']
  show ?thesis by(blast intro: heap_base.heap_clone.intros)
next
  case (Arr T n h' a' FDTs obs h'')
  with jmm'_heap_copiesI[of typeof_addr P a a' "map (λ((F, D), Tfm). CField D F) FDTs @ map ACell [0..<n]"]
  show ?thesis by(blast intro: heap_base.heap_clone.intros)
qed

lemma jmm'_red_externalI:
  "final.
   heap_base.red_external addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr jmm_heap_read jmm_heap_write P t h a M vs ta va h';
     final_thread.actions_ok final s t ta 
   ta va h'. heap_base.red_external addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr (heap_base.heap_read_typed typeof_addr jmm_heap_read P) jmm_heap_write P t h a M vs ta va h'  final_thread.actions_ok final s t ta"
proof(erule heap_base.red_external.cases, goal_cases)
  case 19 (* RedClone *)
  thus ?case apply -
    apply(drule jmm'_heap_cloneI, clarify)
    apply(rename_tac obsa', case_tac obsa')
    by(auto 4 4 intro: heap_base.red_external.intros simp add: final_thread.actions_ok_iff simp del: split_paired_Ex)
next
  case 20 (* RedCloneFail *)
  thus ?case apply -
    apply(drule jmm'_heap_cloneI, clarify)
    apply(rename_tac obsa', case_tac obsa')
    by(auto 4 4 intro: heap_base.red_external.intros simp add: final_thread.actions_ok_iff simp del: split_paired_Ex)
qed(blast intro: heap_base.red_external.intros)+

lemma red_external_aggr_heap_read_typedI:
  "final.
   (ta, vah')  heap_base.red_external_aggr addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr jmm_heap_read jmm_heap_write P t h a M vs;
    final_thread.actions_ok final s t ta
  
   ta vah'. (ta, vah')  heap_base.red_external_aggr addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr (heap_base.heap_read_typed typeof_addr jmm_heap_read P) jmm_heap_write P t h a M vs  final_thread.actions_ok final s t ta"
apply(simp add: heap_base.red_external_aggr_def split_beta split del: if_split split: if_split_asm del: split_paired_Ex)
apply(auto simp del: split_paired_Ex)
 apply(drule jmm'_heap_cloneI)
 apply(clarify)
 apply(rename_tac obsa, case_tac obsa)
  apply(force simp add: final_thread.actions_ok_iff del: disjCI intro: disjI1 disjI2 simp del: split_paired_Ex)
 apply(force simp add: final_thread.actions_ok_iff del: disjCI intro: disjI1 disjI2 simp del: split_paired_Ex)
apply(drule jmm'_heap_cloneI)
apply clarify
apply(rename_tac obsa, case_tac obsa)
 apply(force simp add: final_thread.actions_ok_iff del: disjCI intro: disjI1 disjI2 simp del: split_paired_Ex)
apply(force simp add: final_thread.actions_ok_iff del: disjCI intro: disjI1 disjI2 simp del: split_paired_Ex)
done

end

Theory JMM_J_Typesafe

(*  Title:      JinjaThreads/MM/JMM_J_Typesafe.thy
    Author:     Andreas Lochbihler
*)

section ‹JMM type safety for source code›

theory JMM_J_Typesafe imports
  JMM_Typesafe2
  DRF_J
begin

locale J_allocated_heap_conf' = 
  h: J_heap_conf 
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate "λ_. typeof_addr" heap_read heap_write hconf
    P
  +
  h: J_allocated_heap 
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate "λ_. typeof_addr" heap_read heap_write
    allocated
    P
  +
  heap''
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write
    P
  for addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and hconf :: "'heap  bool"
  and allocated :: "'heap  'addr set"
  and P :: "'addr J_prog"

sublocale J_allocated_heap_conf' < h: J_allocated_heap_conf
  addr2thread_id thread_id2addr
  spurious_wakeups
  empty_heap allocate "λ_. typeof_addr" heap_read heap_write hconf allocated
  P
by(unfold_locales)

context J_allocated_heap_conf' begin

lemma red_New_type_match:
  " h.red' P t e s ta e' s'; NewHeapElem ad CTn  set tao; typeof_addr ad  None 
   typeof_addr ad = CTn" 
  and reds_New_type_match:
  " h.reds' P t es s ta es' s'; NewHeapElem ad CTn  set tao; typeof_addr ad  None 
   typeof_addr ad = CTn"
by(induct rule: h.red_reds.inducts)(auto dest: allocate_typeof_addr_SomeD red_external_New_type_match)

lemma mred_known_addrs_typing':
  assumes wf: "wf_J_prog P"
  and ok: "h.start_heap_ok"
  shows "known_addrs_typing' addr2thread_id thread_id2addr empty_heap allocate typeof_addr heap_write allocated h.J_known_addrs final_expr (h.mred P) (λt x h. ET. h.sconf_type_ok ET t x h) P"
proof -
  interpret known_addrs_typing
    addr2thread_id thread_id2addr 
    spurious_wakeups
    empty_heap allocate "λ_. typeof_addr" heap_read heap_write
    allocated h.J_known_addrs
    final_expr "h.mred P" "λt x h. ET. h.sconf_type_ok ET t x h"
    P
    using assms by(rule h.mred_known_addrs_typing)

  show ?thesis by unfold_locales(auto dest: red_New_type_match)
qed

lemma J_legal_read_value_typeable:
  assumes wf: "wf_J_prog P"
  and wf_start: "h.wf_start_state P C M vs"
  and legal: "weakly_legal_execution P (h.J_ℰ P C M vs status) (E, ws)"
  and a: "enat a < llength E"
  and read: "action_obs E a = NormalAction (ReadMem ad al v)"
  shows "T. P  ad@al : T  P  v :≤ T"
proof -
  note wf
  moreover from wf_start have "h.start_heap_ok" by cases
  moreover from wf wf_start
  have "ts_ok (λt x h. ET. h.sconf_type_ok ET t x h) (thr (h.J_start_state P C M vs)) h.start_heap"
    by(rule h.J_start_state_sconf_type_ok)
  moreover from wf have "wf_syscls P" by(rule wf_prog_wf_syscls)
  ultimately show ?thesis using legal a read
    by(rule known_addrs_typing'.weakly_legal_read_value_typeable[OF mred_known_addrs_typing'])
qed

end

subsection ‹Specific part for JMM implementation 2›

abbreviation jmm_J_ℰ
  :: "addr J_prog  cname  mname  addr val list  status  (addr × (addr, addr) obs_event action) llist set"
where 
  "jmm_J_ℰ P  
  J_heap_base.J_ℰ addr2thread_id thread_id2addr jmm_spurious_wakeups jmm_empty jmm_allocate (jmm_typeof_addr P) jmm_heap_read jmm_heap_write P"

abbreviation jmm'_J_ℰ
  :: "addr J_prog  cname  mname  addr val list  status  (addr × (addr, addr) obs_event action) llist set"
where 
  "jmm'_J_ℰ P  
  J_heap_base.J_ℰ addr2thread_id thread_id2addr jmm_spurious_wakeups jmm_empty jmm_allocate (jmm_typeof_addr P) (jmm_heap_read_typed P) jmm_heap_write P"


lemma jmm_J_heap_conf:
  "J_heap_conf addr2thread_id thread_id2addr jmm_empty jmm_allocate (jmm_typeof_addr P) jmm_heap_write jmm_hconf P"
by(unfold_locales)

lemma jmm_J_allocated_heap_conf: "J_allocated_heap_conf addr2thread_id thread_id2addr jmm_empty jmm_allocate (jmm_typeof_addr P) jmm_heap_write jmm_hconf jmm_allocated P"
by(unfold_locales)


lemma jmm_J_allocated_heap_conf':
  "J_allocated_heap_conf' addr2thread_id thread_id2addr jmm_empty jmm_allocate (jmm_typeof_addr' P) jmm_heap_write jmm_hconf jmm_allocated P"
apply(rule J_allocated_heap_conf'.intro)
apply(unfold jmm_typeof_addr'_conv_jmm_typeof_addr)
apply(unfold_locales)
done


lemma red_heap_read_typedD:
  "J_heap_base.red' addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate (λ_ :: 'heap. typeof_addr) (heap_base.heap_read_typed (λ_ :: 'heap. typeof_addr) heap_read P) heap_write P t e s ta e' s' 
   J_heap_base.red' addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate (λ_ :: 'heap. typeof_addr) heap_read heap_write P t e s ta e' s' 
  (ad al v T. ReadMem ad al v  set tao  heap_base'.addr_loc_type TYPE('heap) typeof_addr P ad al T  heap_base'.conf TYPE('heap) typeof_addr P v T)"
  (is "?lhs1  ?rhs1a  ?rhs1b")
  and reds_heap_read_typedD:
  "J_heap_base.reds' addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate (λ_ :: 'heap. typeof_addr) (heap_base.heap_read_typed (λ_ :: 'heap. typeof_addr) heap_read P) heap_write P t es s ta es' s' 
   J_heap_base.reds' addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate (λ_ :: 'heap. typeof_addr) heap_read heap_write P t es s ta es' s' 
  (ad al v T. ReadMem ad al v  set tao  heap_base'.addr_loc_type TYPE('heap) typeof_addr P ad al T  heap_base'.conf TYPE('heap) typeof_addr P v T)"
  (is "?lhs2  ?rhs2a  ?rhs2b")
proof -
  have "(?lhs1  ?rhs1a  ?rhs1b)  (?lhs2  ?rhs2a  ?rhs2b)"
    apply(induct rule: J_heap_base.red_reds.induct)
    prefer 50 (* RedCallExternal *)
    apply(subst (asm) red_external_heap_read_typed)
    apply(fastforce intro!: J_heap_base.red_reds.RedCallExternal simp add: convert_extTA_def)

    prefer 49 (* RedCall *)
    apply(fastforce dest: J_heap_base.red_reds.RedCall)

    apply(auto intro: J_heap_base.red_reds.intros dest: heap_base.heap_read_typed_into_heap_read heap_base.heap_read_typed_typed dest: heap_base'.addr_loc_type_conv_addr_loc_type[THEN fun_cong, THEN fun_cong, THEN fun_cong, THEN iffD2] heap_base'.conf_conv_conf[THEN fun_cong, THEN fun_cong, THEN iffD1])
    done
  moreover have "(?rhs1a  ?rhs1b  ?lhs1)  (?rhs2a  ?rhs2b  ?lhs2)"
    apply(induct rule: J_heap_base.red_reds.induct)
    prefer 50 (* RedCallExternal *)
    apply simp
    apply(intro strip)
    apply(erule (1) J_heap_base.red_reds.RedCallExternal)
    apply(subst red_external_heap_read_typed, erule conjI)
    apply(blast+)[4]

    prefer 49 (* RedCall *)
    apply(fastforce dest: J_heap_base.red_reds.RedCall)

    apply(auto intro: J_heap_base.red_reds.intros intro!: heap_base.heap_read_typedI dest: heap_base'.addr_loc_type_conv_addr_loc_type[THEN fun_cong, THEN fun_cong, THEN fun_cong, THEN iffD1] intro: heap_base'.conf_conv_conf[THEN fun_cong, THEN fun_cong, THEN iffD2])
    done
  ultimately show "?lhs1  ?rhs1a  ?rhs1b" "?lhs2  ?rhs2a  ?rhs2b" by blast+
qed

lemma if_mred_heap_read_typedD:
  "multithreaded_base.init_fin final_expr (J_heap_base.mred addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate (λ_ :: 'heap. typeof_addr) (heap_base.heap_read_typed (λ_ :: 'heap. typeof_addr) heap_read P) heap_write P) t xh ta x'h' 
   if_heap_read_typed final_expr (J_heap_base.mred addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate (λ_ :: 'heap. typeof_addr) heap_read heap_write P) typeof_addr P t xh ta x'h'"
unfolding multithreaded_base.init_fin.simps
by(subst red_heap_read_typedD) fastforce

lemma J_ℰ_heap_read_typedI:
  " E  J_heap_base.J_ℰ addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate (λ_ :: 'heap. typeof_addr) heap_read heap_write P C M vs status;
     ad al v T.  NormalAction (ReadMem ad al v)  snd ` lset E; heap_base'.addr_loc_type TYPE('heap) typeof_addr P ad al T   heap_base'.conf TYPE('heap) typeof_addr P v T 
   E  J_heap_base.J_ℰ addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate (λ_ :: 'heap. typeof_addr) (heap_base.heap_read_typed (λ_ :: 'heap. typeof_addr) heap_read P) heap_write P C M vs status"
apply(erule imageE, hypsubst)
apply(rule imageI)
apply(erule multithreaded_base.ℰ.cases, hypsubst)
apply(rule multithreaded_base.ℰ.intros)
apply(subst if_mred_heap_read_typedD[abs_def])
apply(erule if_mthr_Runs_heap_read_typedI)
apply(auto simp add: image_Un lset_lmap[symmetric] lmap_lconcat llist.map_comp o_def split_def simp del: lset_lmap)
done

lemma jmm'_redI:
  " J_heap_base.red' addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr jmm_heap_read jmm_heap_write P t e s ta e' s'; 
     final_thread.actions_ok (final_thread.init_fin_final final_expr) S t ta 
   ta e' s'. J_heap_base.red' addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr (heap_base.heap_read_typed typeof_addr jmm_heap_read P) jmm_heap_write P t e s ta e' s'  final_thread.actions_ok (final_thread.init_fin_final final_expr) S t ta"
  (is " ?red'; ?aok   ?concl")
  and jmm'_redsI:
  " J_heap_base.reds' addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr jmm_heap_read jmm_heap_write P t es s ta es' s';
     final_thread.actions_ok (final_thread.init_fin_final final_expr) S t ta 
   ta es' s'. J_heap_base.reds' addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr (heap_base.heap_read_typed typeof_addr jmm_heap_read P) jmm_heap_write P t es s ta es' s'  
     final_thread.actions_ok (final_thread.init_fin_final final_expr) S t ta"
  (is " ?reds'; ?aoks   ?concls")
proof -
  note [simp del] = split_paired_Ex
    and [simp add] = final_thread.actions_ok_iff heap_base.THE_addr_loc_type heap_base.defval_conf
    and [intro] = jmm_heap_read_typed_default_val

  let ?v = "λh a al. default_val (THE T. heap_base.addr_loc_type typeof_addr P h a al T)"

  have "(?red'  ?aok  ?concl)  (?reds'  ?aoks  ?concls)"
  proof(induct rule: J_heap_base.red_reds.induct)
    case (23 h a T n i v l) (* RedAAcc *)
    thus ?case by(auto 4 6 intro: J_heap_base.red_reds.RedAAcc[where v="?v h a (ACell (nat (sint i)))"])
  next
    case (35 h a D F v l) (* RedFAcc *)
    thus ?case by(auto 4 5 intro: J_heap_base.red_reds.RedFAcc[where v="?v h a (CField D F)"])
  next
    case RedCASSucceed: (45 h a D F v v' h') (* RedCASSucceed *)
    thus ?case
    proof(cases "v = ?v h a (CField D F)")
      case True
      with RedCASSucceed show ?thesis
        by(fastforce intro: J_heap_base.red_reds.RedCASSucceed[where v="?v h a (CField D F)"])
    next
      case False
      with RedCASSucceed show ?thesis
        by(fastforce intro: J_heap_base.red_reds.RedCASFail[where v''="?v h a (CField D F)"])
    qed
  next
    case RedCASFail: (46 h a D F v'' v v' l)
    thus ?case
    proof(cases "v = ?v h a (CField D F)")
      case True
      with RedCASFail show ?thesis
        by(fastforce intro: J_heap_base.red_reds.RedCASSucceed[where v="?v h a (CField D F)"] jmm_heap_write.intros)
    next
      case False
      with RedCASFail show ?thesis
        by(fastforce intro: J_heap_base.red_reds.RedCASFail[where v''="?v h a (CField D F)"])
    qed
  next
    case (50 s a hU M Ts T D vs ta va h' ta' e' s') (* RedCallExternal *)
    thus ?case
      apply clarify
      apply(drule jmm'_red_externalI, simp)
      apply(auto 4 4 intro: J_heap_base.red_reds.RedCallExternal)
      done
  next
    case (52 e h l V vo ta e' h' l' T) (* BlockRed *)
    thus ?case
      by(clarify)(iprover intro: J_heap_base.red_reds.BlockRed)
  qed(blast intro: J_heap_base.red_reds.intros)+
  thus " ?red'; ?aok   ?concl" and " ?reds'; ?aoks   ?concls" by blast+
qed

lemma if_mred_heap_read_not_stuck:
  " multithreaded_base.init_fin final_expr (J_heap_base.mred addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr jmm_heap_read jmm_heap_write P) t xh ta x'h';
    final_thread.actions_ok (final_thread.init_fin_final final_expr) s t ta 
  
  ta x'h'. multithreaded_base.init_fin final_expr (J_heap_base.mred addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr (heap_base.heap_read_typed typeof_addr jmm_heap_read P) jmm_heap_write P) t xh ta x'h'  final_thread.actions_ok (final_thread.init_fin_final final_expr) s t ta"
apply(erule multithreaded_base.init_fin.cases)
  apply hypsubst
  apply clarify
  apply(drule jmm'_redI)
   apply(simp add: final_thread.actions_ok_iff)
  apply clarify
  apply(subst (2) split_paired_Ex)
  apply(subst (2) split_paired_Ex)
  apply(subst (2) split_paired_Ex)
  apply(rule exI conjI)+
   apply(rule multithreaded_base.init_fin.intros)
   apply(simp)
  apply(simp add: final_thread.actions_ok_iff)
 apply(blast intro: multithreaded_base.init_fin.intros)
apply(blast intro: multithreaded_base.init_fin.intros)
done

lemma if_mredT_heap_read_not_stuck:
  "multithreaded_base.redT (final_thread.init_fin_final final_expr) (multithreaded_base.init_fin final_expr (J_heap_base.mred addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr jmm_heap_read jmm_heap_write P)) convert_RA' s tta s'
   tta s'. multithreaded_base.redT (final_thread.init_fin_final final_expr) (multithreaded_base.init_fin final_expr (J_heap_base.mred addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr (heap_base.heap_read_typed typeof_addr jmm_heap_read P) jmm_heap_write P)) convert_RA' s tta s'"
apply(erule multithreaded_base.redT.cases)
 apply hypsubst
 apply(drule (1) if_mred_heap_read_not_stuck)
 apply(erule exE)+
 apply(rename_tac ta' x'h')
 apply(insert redT_updWs_total)
 apply(erule_tac x="t" in meta_allE)
 apply(erule_tac x="wset s" in meta_allE)
 apply(erule_tac x="ta'w" in meta_allE)
 apply clarsimp
 apply(rule exI)+
 apply(auto intro!: multithreaded_base.redT.intros)[1]
apply hypsubst
apply(rule exI conjI)+
apply(rule multithreaded_base.redT.redT_acquire)
apply assumption+
done

lemma J_ℰ_heap_read_typedD:
  "E  J_heap_base.J_ℰ addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate (λ_. typeof_addr) (heap_base.heap_read_typed (λ_. typeof_addr) jmm_heap_read P) jmm_heap_write P C M vs status
   E  J_heap_base.J_ℰ addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate (λ_. typeof_addr) jmm_heap_read jmm_heap_write P C M vs status"
apply(erule imageE, hypsubst)
apply(rule imageI)
apply(erule multithreaded_base.ℰ.cases, hypsubst)
apply(rule multithreaded_base.ℰ.intros)
apply(subst (asm) if_mred_heap_read_typedD[abs_def])
apply(erule if_mthr_Runs_heap_read_typedD)
apply(erule if_mredT_heap_read_not_stuck[where typeof_addr="λ_. typeof_addr", unfolded if_mred_heap_read_typedD[abs_def]])
done

lemma J_ℰ_typesafe_subset: "jmm'_J_ℰ P C M vs status  jmm_J_ℰ P C M vs status"
unfolding jmm_typeof_addr_def[abs_def]
by(rule subsetI)(erule J_ℰ_heap_read_typedD)

lemma J_legal_typesafe1:
  assumes wfP: "wf_J_prog P"
  and ok: "jmm_wf_start_state P C M vs"
  and legal: "legal_execution P (jmm_J_ℰ P C M vs status) (E, ws)"
  shows "legal_execution P (jmm'_J_ℰ P C M vs status) (E, ws)"
proof -
  let ?ℰ = "jmm_J_ℰ P C M vs status"
  let ?ℰ' = "jmm'_J_ℰ P C M vs status"
  from legal obtain J 
    where justified: "P  (E, ws) justified_by J"
    and range: "range (justifying_exec  J)  ?ℰ"
    and E: "E  ?ℰ" and wf: "P  (E, ws) " by(auto simp add: gen_legal_execution.simps)
  let ?J = "J(0 := committed = {}, justifying_exec = justifying_exec (J 1), justifying_ws = justifying_ws (J 1), action_translation = id)"

  from wfP have wf_sys: "wf_syscls P" by(rule wf_prog_wf_syscls)

  from justified have "P  (justifying_exec (J 1), justifying_ws (J 1)) "
    by(simp add: justification_well_formed_def)
  with justified have "P  (E, ws) justified_by ?J" by(rule drop_0th_justifying_exec)
  moreover have "range (justifying_exec  ?J)  ?ℰ'"
  proof
    fix ξ
    assume "ξ  range (justifying_exec  ?J)"
    then obtain n where "ξ = justifying_exec (?J n)" by auto
    then obtain n where ξ: "ξ = justifying_exec (J n)" and n: "n > 0" by(auto split: if_split_asm)
    from range ξ have "ξ  ?ℰ" by auto
    thus "ξ  ?ℰ'" unfolding jmm_typeof_addr'_conv_jmm_type_addr[symmetric, abs_def]
    proof(rule J_ℰ_heap_read_typedI)
      fix ad al v T
      assume read: "NormalAction (ReadMem ad al v)  snd ` lset ξ"
        and adal: "P ⊢jmm ad@al : T"
      from read obtain a where a: "enat a < llength ξ" "action_obs ξ a = NormalAction (ReadMem ad al v)"
        unfolding lset_conv_lnth by(auto simp add: action_obs_def)
      with J_allocated_heap_conf'.mred_known_addrs_typing'[OF jmm_J_allocated_heap_conf' wfP jmm_start_heap_ok]
        J_heap_conf.J_start_state_sconf_type_ok[OF jmm_J_heap_conf wfP ok]
        wf_sys is_justified_by_imp_is_weakly_justified_by[OF justified wf] range n
      have "T. P ⊢jmm ad@al : T  P ⊢jmm v :≤ T"
        unfolding jmm_typeof_addr'_conv_jmm_type_addr[symmetric, abs_def] ξ
        by(rule known_addrs_typing'.read_value_typeable_justifying)
      thus "P ⊢jmm v :≤ T" using adal
        by(auto dest: jmm.addr_loc_type_fun[unfolded jmm_typeof_addr_conv_jmm_typeof_addr', unfolded heap_base'.addr_loc_type_conv_addr_loc_type])
    qed
  qed
  moreover from E have "E  ?ℰ'"
    unfolding jmm_typeof_addr'_conv_jmm_type_addr[symmetric, abs_def]
  proof(rule J_ℰ_heap_read_typedI)
    fix ad al v T
    assume read: "NormalAction (ReadMem ad al v)  snd ` lset E"
      and adal: "P ⊢jmm ad@al : T"
    from read obtain a where a: "enat a < llength E" "action_obs E a = NormalAction (ReadMem ad al v)"
      unfolding lset_conv_lnth by(auto simp add: action_obs_def)
    with jmm_J_allocated_heap_conf' wfP ok legal_imp_weakly_legal_execution[OF legal]
    have "T. P ⊢jmm ad@al : T  P ⊢jmm v :≤ T"
      unfolding jmm_typeof_addr'_conv_jmm_type_addr[symmetric, abs_def]
      by(rule J_allocated_heap_conf'.J_legal_read_value_typeable)
    thus "P ⊢jmm v :≤ T" using adal
      by(auto dest: jmm.addr_loc_type_fun[unfolded jmm_typeof_addr_conv_jmm_typeof_addr', unfolded heap_base'.addr_loc_type_conv_addr_loc_type])
  qed
  ultimately show ?thesis using wf unfolding gen_legal_execution.simps by blast
qed

lemma J_weakly_legal_typesafe1:
  assumes wfP: "wf_J_prog P"
  and ok: "jmm_wf_start_state P C M vs"
  and legal: "weakly_legal_execution P (jmm_J_ℰ P C M vs status) (E, ws)"
  shows "weakly_legal_execution P (jmm'_J_ℰ P C M vs status) (E, ws)"
proof -
  let ?ℰ = "jmm_J_ℰ P C M vs status"
  let ?ℰ' = "jmm'_J_ℰ P C M vs status"
  from legal obtain J 
    where justified: "P  (E, ws) weakly_justified_by J"
    and range: "range (justifying_exec  J)  ?ℰ"
    and E: "E  ?ℰ" and wf: "P  (E, ws) " by(auto simp add: gen_legal_execution.simps)
  let ?J = "J(0 := committed = {}, justifying_exec = justifying_exec (J 1), justifying_ws = justifying_ws (J 1), action_translation = id)"

  from wfP have wf_sys: "wf_syscls P" by(rule wf_prog_wf_syscls)

  from justified have "P  (justifying_exec (J 1), justifying_ws (J 1)) "
    by(simp add: justification_well_formed_def)
  with justified have "P  (E, ws) weakly_justified_by ?J" by(rule drop_0th_weakly_justifying_exec)
  moreover have "range (justifying_exec  ?J)  ?ℰ'"
  proof
    fix ξ
    assume "ξ  range (justifying_exec  ?J)"
    then obtain n where "ξ = justifying_exec (?J n)" by auto
    then obtain n where ξ: "ξ = justifying_exec (J n)" and n: "n > 0" by(auto split: if_split_asm)
    from range ξ have "ξ  ?ℰ" by auto
    thus "ξ  ?ℰ'" unfolding jmm_typeof_addr'_conv_jmm_type_addr[symmetric, abs_def]
    proof(rule J_ℰ_heap_read_typedI)
      fix ad al v T
      assume read: "NormalAction (ReadMem ad al v)  snd ` lset ξ"
        and adal: "P ⊢jmm ad@al : T"
      from read obtain a where a: "enat a < llength ξ" "action_obs ξ a = NormalAction (ReadMem ad al v)"
        unfolding lset_conv_lnth by(auto simp add: action_obs_def)
      with J_allocated_heap_conf'.mred_known_addrs_typing'[OF jmm_J_allocated_heap_conf' wfP jmm_start_heap_ok]
        J_heap_conf.J_start_state_sconf_type_ok[OF jmm_J_heap_conf wfP ok]
        wf_sys justified range n
      have "T. P ⊢jmm ad@al : T  P ⊢jmm v :≤ T"
        unfolding jmm_typeof_addr'_conv_jmm_type_addr[symmetric, abs_def] ξ
        by(rule known_addrs_typing'.read_value_typeable_justifying)
      thus "P ⊢jmm v :≤ T" using adal
        by(auto dest: jmm.addr_loc_type_fun[unfolded jmm_typeof_addr_conv_jmm_typeof_addr', unfolded heap_base'.addr_loc_type_conv_addr_loc_type])
    qed
  qed
  moreover from E have "E  ?ℰ'"
    unfolding jmm_typeof_addr'_conv_jmm_type_addr[symmetric, abs_def]
  proof(rule J_ℰ_heap_read_typedI)
    fix ad al v T
    assume read: "NormalAction (ReadMem ad al v)  snd ` lset E"
      and adal: "P ⊢jmm ad@al : T"
    from read obtain a where a: "enat a < llength E" "action_obs E a = NormalAction (ReadMem ad al v)"
      unfolding lset_conv_lnth by(auto simp add: action_obs_def)
    with jmm_J_allocated_heap_conf' wfP ok legal
    have "T. P ⊢jmm ad@al : T  P ⊢jmm v :≤ T"
      unfolding jmm_typeof_addr'_conv_jmm_type_addr[symmetric, abs_def]
      by(rule J_allocated_heap_conf'.J_legal_read_value_typeable)
    thus "P ⊢jmm v :≤ T" using adal
      by(auto dest: jmm.addr_loc_type_fun[unfolded jmm_typeof_addr_conv_jmm_typeof_addr', unfolded heap_base'.addr_loc_type_conv_addr_loc_type])
  qed
  ultimately show ?thesis using wf unfolding gen_legal_execution.simps by blast
qed

lemma J_legal_typesafe2:
  assumes legal: "legal_execution P (jmm'_J_ℰ P C M vs status) (E, ws)"
  shows "legal_execution P (jmm_J_ℰ P C M vs status) (E, ws)"
proof -
  let ?ℰ = "jmm_J_ℰ P C M vs status"
  let ?ℰ' = "jmm'_J_ℰ P C M vs status"
  from legal obtain J 
    where justified: "P  (E, ws) justified_by J"
    and range: "range (justifying_exec  J)  ?ℰ'"
    and E: "E  ?ℰ'" and wf: "P  (E, ws) " by(auto simp add: gen_legal_execution.simps)
  from range E have "range (justifying_exec  J)  ?ℰ" "E  ?ℰ"
    using J_ℰ_typesafe_subset[of P status C M vs] by blast+
  with justified wf
  show ?thesis by(auto simp add: gen_legal_execution.simps)
qed

lemma J_weakly_legal_typesafe2:
  assumes legal: "weakly_legal_execution P (jmm'_J_ℰ P C M vs status) (E, ws)"
  shows "weakly_legal_execution P (jmm_J_ℰ P C M vs status) (E, ws)"
proof -
  let ?ℰ = "jmm_J_ℰ P C M vs status"
  let ?ℰ' = "jmm'_J_ℰ P C M vs status"
  from legal obtain J 
    where justified: "P  (E, ws) weakly_justified_by J"
    and range: "range (justifying_exec  J)  ?ℰ'"
    and E: "E  ?ℰ'" and wf: "P  (E, ws) " by(auto simp add: gen_legal_execution.simps)
  from range E have "range (justifying_exec  J)  ?ℰ" "E  ?ℰ"
    using J_ℰ_typesafe_subset[of P status C M vs] by blast+
  with justified wf
  show ?thesis by(auto simp add: gen_legal_execution.simps)
qed

theorem J_weakly_legal_typesafe:
  assumes "wf_J_prog P"
  and "jmm_wf_start_state P C M vs"
  shows "weakly_legal_execution P (jmm_J_ℰ P C M vs status) = weakly_legal_execution P (jmm'_J_ℰ P C M vs status)"
apply(rule ext iffI)+
 apply(clarify, erule J_weakly_legal_typesafe1[OF assms])
apply(clarify, erule J_weakly_legal_typesafe2)
done

theorem J_legal_typesafe:
  assumes "wf_J_prog P"
  and "jmm_wf_start_state P C M vs"
  shows "legal_execution P (jmm_J_ℰ P C M vs status) = legal_execution P (jmm'_J_ℰ P C M vs status)"
apply(rule ext iffI)+
 apply(clarify, erule J_legal_typesafe1[OF assms])
apply(clarify, erule J_legal_typesafe2)
done

end

Theory JMM_JVM_Typesafe

(*  Title:      JinjaThreads/MM/JMM_JVM_Typesafe.thy
    Author:     Andreas Lochbihler
*)

section ‹JMM type safety for bytecode›

theory JMM_JVM_Typesafe
imports
  JMM_Typesafe2
  DRF_JVM
begin

locale JVM_allocated_heap_conf' = 
  h: JVM_heap_conf 
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate "λ_. typeof_addr" heap_read heap_write hconf
    P
  +
  h: JVM_allocated_heap 
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate "λ_. typeof_addr" heap_read heap_write
    allocated
    P
  +
  heap''
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write
    P
  for addr2thread_id :: "('addr :: addr)  'thread_id"
  and thread_id2addr :: "'thread_id  'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'addr  htype"
  and heap_read :: "'heap  'addr  addr_loc  'addr val  bool"
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap  bool"
  and hconf :: "'heap  bool"
  and allocated :: "'heap  'addr set"
  and P :: "'addr jvm_prog"

sublocale JVM_allocated_heap_conf' < h: JVM_allocated_heap_conf
  addr2thread_id thread_id2addr
  spurious_wakeups
  empty_heap allocate "λ_. typeof_addr" heap_read heap_write hconf allocated
  P
by(unfold_locales)

context JVM_allocated_heap_conf' begin

lemma exec_instr_New_type_match:
  " (ta, s')  h.exec_instr i P t h stk loc C M pc frs; NewHeapElem ad CTn  set tao; typeof_addr ad  None 
   typeof_addr ad = CTn"
by(cases i)(auto split: if_split_asm prod.split_asm dest: allocate_typeof_addr_SomeD red_external_aggr_New_type_match)

lemma mexecd_New_type_match:
  " h.mexecd P t (xcpfrs, h) ta (xcpfrs', h'); NewHeapElem ad CTn  set tao; typeof_addr ad  None 
   typeof_addr ad = CTn"
apply(cases xcpfrs)
apply(cases xcpfrs')
apply(simp add: split_beta)
apply(erule h.jvmd_NormalE)
apply(cases "fst xcpfrs")
apply(auto 4 3 dest: exec_instr_New_type_match)
done

lemma mexecd_known_addrs_typing':
  assumes wf: "wf_jvm_progΦ P"
  and ok: "h.start_heap_ok"
  shows "known_addrs_typing' addr2thread_id thread_id2addr empty_heap allocate typeof_addr heap_write allocated h.jvm_known_addrs JVM_final (h.mexecd P) (λt (xcp, frs) h. h.correct_state Φ t (xcp, h, frs)) P"
proof -
  interpret known_addrs_typing
    addr2thread_id thread_id2addr 
    spurious_wakeups
    empty_heap allocate "λ_. typeof_addr" heap_read heap_write
    allocated h.jvm_known_addrs
    JVM_final "h.mexecd P" "λt (xcp, frs) h. h.correct_state Φ t (xcp, h, frs)"
    P
    using assms by(rule h.mexecd_known_addrs_typing)

  show ?thesis by(unfold_locales)(erule mexecd_New_type_match)
qed

lemma JVM_weakly_legal_read_value_typeable:
  assumes wf: "wf_jvm_progΦ P"
  and wf_start: "h.wf_start_state P C M vs"
  and legal: "weakly_legal_execution P (h.JVMd_ℰ P C M vs status) (E, ws)"
  and a: "enat a < llength E"
  and read: "action_obs E a = NormalAction (ReadMem ad al v)"
  shows "T. P  ad@al : T  P  v :≤ T"
proof -
  note wf
  moreover from wf_start have "h.start_heap_ok" by cases
  moreover from wf wf_start
  have "ts_ok (λt (xcp, frs) h. h.correct_state Φ t (xcp, h, frs)) (thr (h.JVM_start_state P C M vs)) h.start_heap"
    using h.correct_jvm_state_initial[OF wf wf_start]
    by(simp add: h.correct_jvm_state_def h.start_state_def split_beta)
  moreover from wf obtain wf_md where wf': "wf_prog wf_md P" by(blast dest: wt_jvm_progD)
  hence "wf_syscls P" by(rule wf_prog_wf_syscls) 
  ultimately show ?thesis using legal a read
    by(rule known_addrs_typing'.weakly_legal_read_value_typeable[OF mexecd_known_addrs_typing'])
qed

end


abbreviation jmm_JVMd_ℰ
  :: "addr jvm_prog  cname  mname  addr val list  status  (addr × (addr, addr) obs_event action) llist set"
where 
  "jmm_JVMd_ℰ P  
  JVM_heap_base.JVMd_ℰ addr2thread_id thread_id2addr jmm_spurious_wakeups jmm_empty jmm_allocate (jmm_typeof_addr P) jmm_heap_read jmm_heap_write P"

abbreviation jmm'_JVMd_ℰ
  :: "addr jvm_prog  cname  mname  addr val list  status  (addr × (addr, addr) obs_event action) llist set"
where 
  "jmm'_JVMd_ℰ P  
  JVM_heap_base.JVMd_ℰ addr2thread_id thread_id2addr jmm_spurious_wakeups jmm_empty jmm_allocate (jmm_typeof_addr P) (jmm_heap_read_typed P) jmm_heap_write P"

abbreviation jmm_JVM_start_state
  :: "addr jvm_prog  cname  mname  addr val list  (addr,thread_id,addr jvm_thread_state,JMM_heap,addr) state"
where "jmm_JVM_start_state  JVM_heap_base.JVM_start_state addr2thread_id jmm_empty jmm_allocate"

lemma jmm_JVM_heap_conf:
  "JVM_heap_conf addr2thread_id thread_id2addr jmm_empty jmm_allocate (jmm_typeof_addr P) jmm_heap_write jmm_hconf P"
by(unfold_locales)

lemma jmm_JVMd_allocated_heap_conf':
  "JVM_allocated_heap_conf' addr2thread_id thread_id2addr jmm_empty jmm_allocate (jmm_typeof_addr' P) jmm_heap_write jmm_hconf jmm_allocated P"
apply(rule JVM_allocated_heap_conf'.intro)
apply(unfold jmm_typeof_addr'_conv_jmm_typeof_addr)
apply(unfold_locales)
done


lemma exec_instr_heap_read_typed:
  "(ta, xcphfrs')  JVM_heap_base.exec_instr addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate (λ_ :: 'heap. typeof_addr) (heap_base.heap_read_typed (λ_ :: 'heap. typeof_addr) heap_read P) heap_write i P t h stk loc C M pc frs 
   (ta, xcphfrs')  JVM_heap_base.exec_instr addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate (λ_ :: 'heap. typeof_addr) heap_read heap_write i P t h stk loc C M pc frs 
   (ad al v T. ReadMem ad al v  set tao  heap_base'.addr_loc_type TYPE('heap) typeof_addr P ad al T  heap_base'.conf TYPE('heap) typeof_addr P v T)"
apply(cases i)
apply(simp_all add: JVM_heap_base.exec_instr.simps split_beta cong: conj_cong)

apply(auto dest: heap_base.heap_read_typed_into_heap_read del: disjCI)[5]
apply(blast dest:  heap_base.heap_read_typed_typed heap_base'.addr_loc_type_conv_addr_loc_type[THEN fun_cong, THEN fun_cong, THEN fun_cong, THEN iffD2] heap_base'.conf_conv_conf[THEN fun_cong, THEN fun_cong, THEN iffD1])
apply(auto dest: heap_base'.addr_loc_type_conv_addr_loc_type[THEN fun_cong, THEN fun_cong, THEN fun_cong, THEN iffD1] intro: heap_base'.conf_conv_conf[THEN fun_cong, THEN fun_cong, THEN iffD2] heap_base.heap_read_typedI)[1]
apply(blast dest:  heap_base.heap_read_typed_typed heap_base'.addr_loc_type_conv_addr_loc_type[THEN fun_cong, THEN fun_cong, THEN fun_cong, THEN iffD2] heap_base'.conf_conv_conf[THEN fun_cong, THEN fun_cong, THEN iffD1])
apply(auto dest: heap_base'.addr_loc_type_conv_addr_loc_type[THEN fun_cong, THEN fun_cong, THEN fun_cong, THEN iffD1] intro: heap_base'.conf_conv_conf[THEN fun_cong, THEN fun_cong, THEN iffD2] heap_base.heap_read_typedI)[1]
apply(blast dest:  heap_base.heap_read_typed_typed heap_base'.addr_loc_type_conv_addr_loc_type[THEN fun_cong, THEN fun_cong, THEN fun_cong, THEN iffD2] heap_base'.conf_conv_conf[THEN fun_cong, THEN fun_cong, THEN iffD1])
subgoal by(auto dest: heap_base.heap_read_typed_into_heap_read)
apply(blast dest:  heap_base.heap_read_typed_typed heap_base'.addr_loc_type_conv_addr_loc_type[THEN fun_cong, THEN fun_cong, THEN fun_cong, THEN iffD2] heap_base'.conf_conv_conf[THEN fun_cong, THEN fun_cong, THEN iffD1])
subgoal by(auto dest: heap_base'.addr_loc_type_conv_addr_loc_type[THEN fun_cong, THEN fun_cong, THEN fun_cong, THEN iffD1] intro: heap_base'.conf_conv_conf[THEN fun_cong, THEN fun_cong, THEN iffD2] heap_base.heap_read_typedI)[1]
subgoal by(auto 4 3 dest: heap_base.heap_read_typed_into_heap_read intro: heap_base.heap_read_typedI simp add: heap_base'.conf_conv_conf heap_base'.addr_loc_type_conv_addr_loc_type)

apply(subst red_external_aggr_heap_read_typed)
apply(fastforce)
apply auto
done

lemma exec_heap_read_typed:
  "(ta, xcphfrs')  JVM_heap_base.exec addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate (λ_ :: 'heap. typeof_addr) (heap_base.heap_read_typed (λ_. typeof_addr) heap_read P) heap_write P t xcphfrs 
   (ta, xcphfrs')  JVM_heap_base.exec addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate (λ_ :: 'heap. typeof_addr) heap_read heap_write P t xcphfrs 
   (ad al v T. ReadMem ad al v  set tao  heap_base'.addr_loc_type TYPE('heap) typeof_addr P ad al T  heap_base'.conf TYPE('heap) typeof_addr P v T)"
apply(cases xcphfrs)
apply(cases "fst xcphfrs")
apply(case_tac [!] "snd (snd xcphfrs)")
apply(auto simp add: JVM_heap_base.exec.simps exec_instr_heap_read_typed)
done

lemma exec_1_d_heap_read_typed:
  "JVM_heap_base.exec_1_d addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate (λ_ :: 'heap. typeof_addr) (heap_base.heap_read_typed (λ_. typeof_addr) heap_read P) heap_write P t (Normal xcphfrs) ta (Normal xcphfrs') 
   JVM_heap_base.exec_1_d addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate (λ_ :: 'heap. typeof_addr) heap_read heap_write P t (Normal xcphfrs) ta (Normal xcphfrs') 
   (ad al v T. ReadMem ad al v  set tao  heap_base'.addr_loc_type TYPE('heap) typeof_addr P ad al T  heap_base'.conf TYPE('heap) typeof_addr P v T)"
by(auto elim!: JVM_heap_base.jvmd_NormalE intro: JVM_heap_base.exec_1_d_NormalI simp add: exec_heap_read_typed JVM_heap_base.exec_d_def)

lemma mexecd_heap_read_typed:
  "JVM_heap_base.mexecd addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate (λ_ :: 'heap. typeof_addr) (heap_base.heap_read_typed (λ_ :: 'heap. typeof_addr) heap_read P) heap_write P t xcpfrsh ta xcpfrsh' 
   JVM_heap_base.mexecd addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate (λ_ :: 'heap. typeof_addr) heap_read heap_write P t xcpfrsh ta xcpfrsh' 
   (ad al v T. ReadMem ad al v  set tao  heap_base'.addr_loc_type TYPE('heap) typeof_addr P ad al T  heap_base'.conf TYPE('heap) typeof_addr P v T)"
by(simp add: split_beta exec_1_d_heap_read_typed)

lemma if_mexecd_heap_read_typed:
  "multithreaded_base.init_fin JVM_final (JVM_heap_base.mexecd addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate (λ_ :: 'heap. typeof_addr) (heap_base.heap_read_typed (λ_ :: 'heap. typeof_addr) heap_read P) heap_write P) t xh ta x'h' 
   if_heap_read_typed JVM_final (JVM_heap_base.mexecd addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate (λ_ :: 'heap. typeof_addr) heap_read heap_write P) typeof_addr P t xh ta x'h'"
unfolding multithreaded_base.init_fin.simps
by(subst mexecd_heap_read_typed) fastforce

lemma JVMd_ℰ_heap_read_typedI:
  " E  JVM_heap_base.JVMd_ℰ addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate (λ_ :: 'heap. typeof_addr) heap_read heap_write P C M vs status;
     ad al v T.  NormalAction (ReadMem ad al v)  snd ` lset E; heap_base'.addr_loc_type TYPE('heap) typeof_addr P ad al T   heap_base'.conf TYPE('heap) typeof_addr P v T 
   E  JVM_heap_base.JVMd_ℰ addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate (λ_ :: 'heap. typeof_addr) (heap_base.heap_read_typed (λ_ :: 'heap. typeof_addr) heap_read P) heap_write P C M vs status"
apply(erule imageE, hypsubst)
apply(rule imageI)
apply(erule multithreaded_base.ℰ.cases, hypsubst)
apply(rule multithreaded_base.ℰ.intros)
apply(subst if_mexecd_heap_read_typed[abs_def])
apply(erule if_mthr_Runs_heap_read_typedI)
apply(auto simp add: image_Un lset_lmap[symmetric] lmap_lconcat llist.map_comp o_def split_def simp del: lset_lmap)
done

lemma jmm'_exec_instrI:
  " (ta, xcphfrs)  JVM_heap_base.exec_instr addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr jmm_heap_read jmm_heap_write i P t h stk loc C M pc frs; 
     final_thread.actions_ok (final_thread.init_fin_final JVM_final) s t ta 
   ta xcphfrs. (ta, xcphfrs)  JVM_heap_base.exec_instr addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr (heap_base.heap_read_typed typeof_addr jmm_heap_read P) jmm_heap_write i P t h stk loc C M pc frs  final_thread.actions_ok (final_thread.init_fin_final JVM_final) s t ta"
apply(cases i)
apply(auto simp add: JVM_heap_base.exec_instr.simps split_beta final_thread.actions_ok_iff intro!: jmm_heap_read_typed_default_val rev_image_eqI simp del: split_paired_Ex split: if_split_asm)
subgoal for F D
  apply(cases "hd (tl stk) = (default_val (THE T. heap_base.addr_loc_type typeof_addr P h (the_Addr (hd (tl (tl stk)))) (CField D F) T))")
  subgoal by(auto simp add: JVM_heap_base.exec_instr.simps split_beta final_thread.actions_ok_iff intro!: jmm_heap_read_typed_default_val rev_image_eqI simp del: split_paired_Ex split: if_split_asm del: disjCI intro!: disjI1 exI)
  subgoal by(auto simp add: JVM_heap_base.exec_instr.simps split_beta final_thread.actions_ok_iff intro!: jmm_heap_read_typed_default_val rev_image_eqI simp del: split_paired_Ex split: if_split_asm del: disjCI intro!: disjI2 exI)
  done
subgoal for F D
  apply(cases "hd (tl stk) = (default_val (THE T. heap_base.addr_loc_type typeof_addr P h (the_Addr (hd (tl (tl stk)))) (CField D F) T))")
  subgoal by(auto simp add: JVM_heap_base.exec_instr.simps split_beta final_thread.actions_ok_iff intro!: jmm_heap_read_typed_default_val rev_image_eqI simp del: split_paired_Ex split: if_split_asm del: disjCI intro!: disjI1 exI jmm_heap_write.intros)
  subgoal by(rule exI conjI disjI2 refl jmm_heap_read_typed_default_val|assumption)+ auto
  done
subgoal by(drule red_external_aggr_heap_read_typedI)(fastforce simp add: final_thread.actions_ok_iff simp del: split_paired_Ex)+
done

lemma jmm'_execI:
  " (ta, xcphfrs')  JVM_heap_base.exec addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr jmm_heap_read jmm_heap_write P t xcphfrs;
     final_thread.actions_ok (final_thread.init_fin_final JVM_final) s t ta 
   ta xcphfrs'. (ta, xcphfrs')  JVM_heap_base.exec addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr (heap_base.heap_read_typed typeof_addr jmm_heap_read P) jmm_heap_write P t xcphfrs  final_thread.actions_ok (final_thread.init_fin_final JVM_final) s t ta"
apply(cases xcphfrs)
apply(cases "snd (snd xcphfrs)")
 apply(simp add: JVM_heap_base.exec.simps)
apply(cases "fst xcphfrs")
apply(fastforce simp add: JVM_heap_base.exec.simps dest!: jmm'_exec_instrI)+
done

lemma jmm'_execdI:
  " JVM_heap_base.exec_1_d addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr jmm_heap_read jmm_heap_write P t (Normal xcphfrs) ta (Normal xcphfrs');
     final_thread.actions_ok (final_thread.init_fin_final JVM_final) s t ta 
   ta xcphfrs'. JVM_heap_base.exec_1_d addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr (heap_base.heap_read_typed typeof_addr jmm_heap_read P) jmm_heap_write P t (Normal xcphfrs) ta (Normal xcphfrs')  final_thread.actions_ok (final_thread.init_fin_final JVM_final) s t ta"
apply(erule JVM_heap_base.jvmd_NormalE)
apply(drule (1) jmm'_execI)
apply(force intro: JVM_heap_base.exec_1_d_NormalI simp add: JVM_heap_base.exec_d_def)
done

lemma jmm'_mexecdI:
  " JVM_heap_base.mexecd addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr jmm_heap_read jmm_heap_write P t xcpfrsh ta xcpfrsh';
     final_thread.actions_ok (final_thread.init_fin_final JVM_final) s t ta 
   ta xcpfrsh'. JVM_heap_base.mexecd addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr (heap_base.heap_read_typed typeof_addr jmm_heap_read P) jmm_heap_write P t xcpfrsh ta xcpfrsh'  final_thread.actions_ok (final_thread.init_fin_final JVM_final) s t ta"
by(simp add: split_beta)(drule (1) jmm'_execdI, auto 4 10)

lemma if_mexecd_heap_read_not_stuck:
  " multithreaded_base.init_fin JVM_final (JVM_heap_base.mexecd addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr jmm_heap_read jmm_heap_write P) t xh ta x'h';
     final_thread.actions_ok (final_thread.init_fin_final JVM_final) s t ta 
   ta x'h'. multithreaded_base.init_fin JVM_final (JVM_heap_base.mexecd addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr (heap_base.heap_read_typed typeof_addr jmm_heap_read P) jmm_heap_write P) t xh ta x'h'  final_thread.actions_ok (final_thread.init_fin_final JVM_final) s t ta"
apply(erule multithreaded_base.init_fin.cases)
  apply hypsubst
  apply(drule jmm'_mexecdI)
   apply(simp add: final_thread.actions_ok_iff)
  apply clarify
  apply(subst (2) split_paired_Ex)
  apply(subst (2) split_paired_Ex)
  apply(subst (2) split_paired_Ex)
  apply(rule exI conjI)+
   apply(rule multithreaded_base.init_fin.intros)
   apply simp
  apply(simp add: final_thread.actions_ok_iff)
 apply(blast intro: multithreaded_base.init_fin.intros)
apply(blast intro: multithreaded_base.init_fin.intros)
done

lemma if_mExecd_heap_read_not_stuck:
  "multithreaded_base.redT (final_thread.init_fin_final JVM_final) (multithreaded_base.init_fin JVM_final (JVM_heap_base.mexecd addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr jmm_heap_read jmm_heap_write P)) convert_RA' s tta s'
   tta s'. multithreaded_base.redT (final_thread.init_fin_final JVM_final) (multithreaded_base.init_fin JVM_final (JVM_heap_base.mexecd addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr (heap_base.heap_read_typed typeof_addr jmm_heap_read P) jmm_heap_write P)) convert_RA' s tta s'"
apply(erule multithreaded_base.redT.cases)
 apply hypsubst
 thm if_mexecd_heap_read_not_stuck
 apply(drule (1) if_mexecd_heap_read_not_stuck)
 apply(erule exE)+
 apply(rename_tac ta' x'h')
 apply(insert redT_updWs_total)
 apply(erule_tac x="t" in meta_allE)
 apply(erule_tac x="wset s" in meta_allE)
 apply(erule_tac x="ta'w" in meta_allE)
 apply clarsimp
 apply(rule exI)+
 apply(auto intro!: multithreaded_base.redT.intros)[1]
apply hypsubst
apply(rule exI conjI)+
apply(rule multithreaded_base.redT.redT_acquire)
apply assumption+
done

lemma JVM_legal_typesafe1:
  assumes wfP: "wf_jvm_prog P"
  and ok: "jmm_wf_start_state P C M vs"
  and legal: "legal_execution P (jmm_JVMd_ℰ P C M vs status) (E, ws)"
  shows "legal_execution P (jmm'_JVMd_ℰ P C M vs status) (E, ws)"
proof -
  let ?ℰ = "jmm_JVMd_ℰ P C M vs status"
  let ?ℰ' = "jmm'_JVMd_ℰ P C M vs status"
  from legal obtain J 
    where justified: "P  (E, ws) justified_by J"
    and range: "range (justifying_exec  J)  ?ℰ"
    and E: "E  ?ℰ" and wf: "P  (E, ws) " by(auto simp add: gen_legal_execution.simps)
  let ?J = "J(0 := committed = {}, justifying_exec = justifying_exec (J 1), justifying_ws = justifying_ws (J 1), action_translation = id)"

  from wfP obtain Φ where Φ: "wf_jvm_progΦ P" by(auto simp add: wf_jvm_prog_def)
  hence wf_sys: "wf_syscls P" by(auto dest: wt_jvm_progD intro: wf_prog_wf_syscls)

  from justified have "P  (justifying_exec (J 1), justifying_ws (J 1)) " by(simp add: justification_well_formed_def)
  with justified have "P  (E, ws) justified_by ?J" by(rule drop_0th_justifying_exec)
  moreover have "range (justifying_exec  ?J)  ?ℰ'"
  proof
    fix ξ
    assume "ξ  range (justifying_exec  ?J)"
    then obtain n where "ξ = justifying_exec (?J n)" by auto
    then obtain n where ξ: "ξ = justifying_exec (J n)" and n: "n > 0" by(auto split: if_split_asm)
    from range ξ have "ξ  ?ℰ" by auto
    thus "ξ  ?ℰ'" unfolding jmm_typeof_addr'_conv_jmm_type_addr[symmetric, abs_def]
    proof(rule JVMd_ℰ_heap_read_typedI)
      fix ad al v T
      assume read: "NormalAction (ReadMem ad al v)  snd ` lset ξ"
        and adal: "P ⊢jmm ad@al : T"
      from read obtain a where a: "enat a < llength ξ" "action_obs ξ a = NormalAction (ReadMem ad al v)"
        unfolding lset_conv_lnth by(auto simp add: action_obs_def)

      have "ts_ok (λt (xcp, frs) h. JVM_heap_conf_base.correct_state addr2thread_id jmm_empty jmm_allocate (λ_. jmm_typeof_addr' P) jmm_hconf P Φ t (xcp, h, frs)) (thr (jmm_JVM_start_state P C M vs)) jmm.start_heap"

        using JVM_heap_conf.correct_jvm_state_initial[OF jmm_JVM_heap_conf Φ ok]
        by(simp add: JVM_heap_conf_base.correct_jvm_state_def jmm_typeof_addr'_conv_jmm_typeof_addr heap_base.start_state_def split_beta)
      with JVM_allocated_heap_conf'.mexecd_known_addrs_typing'[OF jmm_JVMd_allocated_heap_conf' Φ jmm_start_heap_ok]
      have "T. P ⊢jmm ad@al : T  P ⊢jmm v :≤ T"
        using wf_sys is_justified_by_imp_is_weakly_justified_by[OF justified wf] range n a
        unfolding jmm_typeof_addr'_conv_jmm_type_addr[symmetric, abs_def] ξ
        by(rule known_addrs_typing'.read_value_typeable_justifying)
      thus "P ⊢jmm v :≤ T" using adal
        by(auto dest: jmm.addr_loc_type_fun[unfolded jmm_typeof_addr_conv_jmm_typeof_addr', unfolded heap_base'.addr_loc_type_conv_addr_loc_type])
    qed
  qed
  moreover from E have "E  ?ℰ'"
    unfolding jmm_typeof_addr'_conv_jmm_type_addr[symmetric, abs_def]
  proof(rule JVMd_ℰ_heap_read_typedI)
    fix ad al v T
    assume read: "NormalAction (ReadMem ad al v)  snd ` lset E"
      and adal: "P ⊢jmm ad@al : T"
    from read obtain a where a: "enat a < llength E" "action_obs E a = NormalAction (ReadMem ad al v)"
      unfolding lset_conv_lnth by(auto simp add: action_obs_def)
    with jmm_JVMd_allocated_heap_conf' Φ ok legal_imp_weakly_legal_execution[OF legal]
    have "T. P ⊢jmm ad@al : T  P ⊢jmm v :≤ T"
      unfolding jmm_typeof_addr'_conv_jmm_typeof_addr[symmetric, abs_def]
      by(rule JVM_allocated_heap_conf'.JVM_weakly_legal_read_value_typeable)
    thus "P ⊢jmm v :≤ T" using adal
      by(auto dest: jmm.addr_loc_type_fun[unfolded jmm_typeof_addr_conv_jmm_typeof_addr', unfolded heap_base'.addr_loc_type_conv_addr_loc_type])
  qed
  ultimately show ?thesis using wf unfolding gen_legal_execution.simps by blast
qed

lemma JVM_weakly_legal_typesafe1:
  assumes wfP: "wf_jvm_prog P"
  and ok: "jmm_wf_start_state P C M vs"
  and legal: "weakly_legal_execution P (jmm_JVMd_ℰ P C M vs status) (E, ws)"
  shows "weakly_legal_execution P (jmm'_JVMd_ℰ P C M vs status) (E, ws)"
proof -
  let ?ℰ = "jmm_JVMd_ℰ P C M vs status"
  let ?ℰ' = "jmm'_JVMd_ℰ P C M vs status"
  from legal obtain J 
    where justified: "P  (E, ws) weakly_justified_by J"
    and range: "range (justifying_exec  J)  ?ℰ"
    and E: "E  ?ℰ" and wf: "P  (E, ws) " by(auto simp add: gen_legal_execution.simps)
  let ?J = "J(0 := committed = {}, justifying_exec = justifying_exec (J 1), justifying_ws = justifying_ws (J 1), action_translation = id)"

  from wfP obtain Φ where Φ: "wf_jvm_progΦ P" by(auto simp add: wf_jvm_prog_def)
  hence wf_sys: "wf_syscls P" by(auto dest: wt_jvm_progD intro: wf_prog_wf_syscls)

  from justified have "P  (justifying_exec (J 1), justifying_ws (J 1)) " by(simp add: justification_well_formed_def)
  with justified have "P  (E, ws) weakly_justified_by ?J" by(rule drop_0th_weakly_justifying_exec)
  moreover have "range (justifying_exec  ?J)  ?ℰ'"
  proof
    fix ξ
    assume "ξ  range (justifying_exec  ?J)"
    then obtain n where "ξ = justifying_exec (?J n)" by auto
    then obtain n where ξ: "ξ = justifying_exec (J n)" and n: "n > 0" by(auto split: if_split_asm)
    from range ξ have "ξ  ?ℰ" by auto
    thus "ξ  ?ℰ'" unfolding jmm_typeof_addr'_conv_jmm_type_addr[symmetric, abs_def]
    proof(rule JVMd_ℰ_heap_read_typedI)
      fix ad al v T
      assume read: "NormalAction (ReadMem ad al v)  snd ` lset ξ"
        and adal: "P ⊢jmm ad@al : T"
      from read obtain a where a: "enat a < llength ξ" "action_obs ξ a = NormalAction (ReadMem ad al v)"
        unfolding lset_conv_lnth by(auto simp add: action_obs_def)

      have "ts_ok (λt (xcp, frs) h. JVM_heap_conf_base.correct_state addr2thread_id jmm_empty jmm_allocate (λ_. jmm_typeof_addr' P) jmm_hconf P Φ t (xcp, h, frs)) (thr (jmm_JVM_start_state P C M vs)) jmm.start_heap"

        using JVM_heap_conf.correct_jvm_state_initial[OF jmm_JVM_heap_conf Φ ok]
        by(simp add: JVM_heap_conf_base.correct_jvm_state_def jmm_typeof_addr'_conv_jmm_typeof_addr heap_base.start_state_def split_beta)
      with JVM_allocated_heap_conf'.mexecd_known_addrs_typing'[OF jmm_JVMd_allocated_heap_conf' Φ jmm_start_heap_ok]
      have "T. P ⊢jmm ad@al : T  P ⊢jmm v :≤ T"
        using wf_sys justified range n a
        unfolding jmm_typeof_addr'_conv_jmm_type_addr[symmetric, abs_def] ξ
        by(rule known_addrs_typing'.read_value_typeable_justifying)
      thus "P ⊢jmm v :≤ T" using adal
        by(auto dest: jmm.addr_loc_type_fun[unfolded jmm_typeof_addr_conv_jmm_typeof_addr', unfolded heap_base'.addr_loc_type_conv_addr_loc_type])
    qed
  qed
  moreover from E have "E  ?ℰ'"
    unfolding jmm_typeof_addr'_conv_jmm_type_addr[symmetric, abs_def]
  proof(rule JVMd_ℰ_heap_read_typedI)
    fix ad al v T
    assume read: "NormalAction (ReadMem ad al v)  snd ` lset E"
      and adal: "P ⊢jmm ad@al : T"
    from read obtain a where a: "enat a < llength E" "action_obs E a = NormalAction (ReadMem ad al v)"
      unfolding lset_conv_lnth by(auto simp add: action_obs_def)
    with jmm_JVMd_allocated_heap_conf' Φ ok legal
    have "T. P ⊢jmm ad@al : T  P ⊢jmm v :≤ T"
      unfolding jmm_typeof_addr'_conv_jmm_typeof_addr[symmetric, abs_def]
      by(rule JVM_allocated_heap_conf'.JVM_weakly_legal_read_value_typeable)
    thus "P ⊢jmm v :≤ T" using adal
      by(auto dest: jmm.addr_loc_type_fun[unfolded jmm_typeof_addr_conv_jmm_typeof_addr', unfolded heap_base'.addr_loc_type_conv_addr_loc_type])
  qed
  ultimately show ?thesis using wf unfolding gen_legal_execution.simps by blast
qed

lemma JVMd_ℰ_heap_read_typedD:
  "E  JVM_heap_base.JVMd_ℰ addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate (λ_. typeof_addr) (heap_base.heap_read_typed (λ_. typeof_addr) jmm_heap_read P) jmm_heap_write P C M vs status
   E  JVM_heap_base.JVMd_ℰ addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate (λ_. typeof_addr) jmm_heap_read jmm_heap_write P C M vs status"
apply(erule imageE, hypsubst)
apply(rule imageI)
apply(erule multithreaded_base.ℰ.cases, hypsubst)
apply(rule multithreaded_base.ℰ.intros)
apply(subst (asm) if_mexecd_heap_read_typed[abs_def])
apply(erule if_mthr_Runs_heap_read_typedD)
apply(erule if_mExecd_heap_read_not_stuck[where typeof_addr="λ_. typeof_addr", unfolded if_mexecd_heap_read_typed[abs_def]])
done

lemma JVMd_ℰ_typesafe_subset: "jmm'_JVMd_ℰ P C M vs status  jmm_JVMd_ℰ P C M vs status"
unfolding jmm_typeof_addr_def[abs_def]
by(rule subsetI)(erule JVMd_ℰ_heap_read_typedD)

lemma JVMd_legal_typesafe2:
  assumes legal: "legal_execution P (jmm'_JVMd_ℰ P C M vs status) (E, ws)"
  shows "legal_execution P (jmm_JVMd_ℰ P C M vs status) (E, ws)"
proof -
  let ?ℰ = "jmm_JVMd_ℰ P C M vs status"
  let ?ℰ' = "jmm'_JVMd_ℰ P C M vs status"
  from legal obtain J 
    where justified: "P  (E, ws) justified_by J"
    and range: "range (justifying_exec  J)  ?ℰ'"
    and E: "E  ?ℰ'" and wf: "P  (E, ws) " by(auto simp add: gen_legal_execution.simps)
  from range E have "range (justifying_exec  J)  ?ℰ" "E  ?ℰ"
    using JVMd_ℰ_typesafe_subset[of P status C M vs] by blast+
  with justified wf
  show ?thesis by(auto simp add: gen_legal_execution.simps)
qed

theorem JVMd_weakly_legal_typesafe2:
  assumes legal: "weakly_legal_execution P (jmm'_JVMd_ℰ P C M vs status) (E, ws)"
  shows "weakly_legal_execution P (jmm_JVMd_ℰ P C M vs status) (E, ws)"
proof -
  let ?ℰ = "jmm_JVMd_ℰ P C M vs status"
  let ?ℰ' = "jmm'_JVMd_ℰ P C M vs status"
  from legal obtain J 
    where justified: "P  (E, ws) weakly_justified_by J"
    and range: "range (justifying_exec  J)  ?ℰ'"
    and E: "E  ?ℰ'" and wf: "P  (E, ws) " by(auto simp add: gen_legal_execution.simps)
  from range E have "range (justifying_exec  J)  ?ℰ" "E  ?ℰ"
    using JVMd_ℰ_typesafe_subset[of P status C M vs] by blast+
  with justified wf
  show ?thesis by(auto simp add: gen_legal_execution.simps)
qed

theorem JVMd_weakly_legal_typesafe:
  assumes "wf_jvm_prog P"
  and "jmm_wf_start_state P C M vs"
  shows "weakly_legal_execution P (jmm_JVMd_ℰ P C M vs status) = weakly_legal_execution P (jmm'_JVMd_ℰ P C M vs status)"
apply(rule ext iffI)+
 apply(clarify, erule JVM_weakly_legal_typesafe1[OF assms])
apply(clarify, erule JVMd_weakly_legal_typesafe2)
done

theorem JVMd_legal_typesafe:
  assumes "wf_jvm_prog P"
  and "jmm_wf_start_state P C M vs"
  shows "legal_execution P (jmm_JVMd_ℰ P C M vs status) = legal_execution P (jmm'_JVMd_ℰ P C M vs status)"
apply(rule ext iffI)+
 apply(clarify, erule JVM_legal_typesafe1[OF assms])
apply(clarify, erule JVMd_legal_typesafe2)
done

end

Theory JMM_Compiler_Type2

(*  Title:      JinjaThreads/MM/JMM_Compiler_Type2.thy
    Author:     Andreas Lochbihler
*)

section ‹Compiler correctness for JMM heap implementation 2›

theory JMM_Compiler_Type2
imports
  JMM_Compiler
  JMM_J_Typesafe
  JMM_JVM_Typesafe
  JMM_Interp
begin

theorem J2JVM_jmm_correct:
  assumes wf: "wf_J_prog P"
  and wf_start: "jmm_wf_start_state P C M vs"
  shows "legal_execution P (jmm_J_ℰ P C M vs Running) (E, ws)  
         legal_execution (J2JVM P) (jmm_JVMd_ℰ (J2JVM P) C M vs Running) (E, ws)"
using JVMd_legal_typesafe[OF wt_J2JVM[OF wf], of C M vs Running, symmetric] wf_start
by(simp only: J_legal_typesafe[OF assms] J_JVM_conf_read.red_ℰ_eq_mexecd_ℰ[OF jmm'_J_JVM_conf_read assms] J2JVM_def o_apply compP1_def compP2_def legal_execution_compP heap_base.wf_start_state_compP jmm_typeof_addr_compP heap_base.heap_read_typed_compP)

theorem J2JVM_jmm_correct_weak:
  assumes wf: "wf_J_prog P"
  and wf_start: "jmm_wf_start_state P C M vs"
  shows "weakly_legal_execution P (jmm_J_ℰ P C M vs Running) (E, ws)  
         weakly_legal_execution (J2JVM P) (jmm_JVMd_ℰ (J2JVM P) C M vs Running) (E, ws)"
using JVMd_weakly_legal_typesafe[OF wt_J2JVM[OF wf], of C M vs Running, symmetric] wf_start
by(simp only: J_weakly_legal_typesafe[OF assms] J_JVM_conf_read.red_ℰ_eq_mexecd_ℰ[OF jmm'_J_JVM_conf_read assms] J2JVM_def o_apply compP1_def compP2_def weakly_legal_execution_compP heap_base.wf_start_state_compP jmm_typeof_addr_compP heap_base.heap_read_typed_compP)

theorem J2JVM_jmm_correctly_synchronized:
  assumes wf: "wf_J_prog P"
  and wf_start: "jmm_wf_start_state P C M vs"
  and ka: "(ka_Val ` set vs)  set jmm.start_addrs"
  shows "correctly_synchronized (J2JVM P) (jmm_JVMd_ℰ (J2JVM P) C M vs Running)  
         correctly_synchronized P (jmm_J_ℰ P C M vs Running)"
  (is "?lhs  ?rhs")
proof
  assume ?lhs
  show ?rhs unfolding correctly_synchronized_def
  proof(intro strip)
    fix E ws a a'
    assume E: "E  jmm_J_ℰ P C M vs Running"
      and wf_exec: "P  (E, ws) "
      and sc: "sequentially_consistent P (E, ws)"
      and actions: "a  actions E" "a'  actions E"
      and conflict: "P,E  a  a'"

    from E wf_exec sc
    have "legal_execution P (jmm_J_ℰ P C M vs Running) (E, ws)"
      by(rule sc_legal.SC_is_legal[OF J_allocated_progress.J_sc_legal[OF jmm_J_allocated_progress wf jmm_heap_read_typeable wf_start ka]])
    hence "legal_execution (J2JVM P) (jmm_JVMd_ℰ (J2JVM P) C M vs Running) (E, ws)"
      by(simp only: J2JVM_jmm_correct[OF wf wf_start])
    hence "E  jmm_JVMd_ℰ (J2JVM P) C M vs Running" "J2JVM P  (E, ws) "
      by(simp_all add: gen_legal_execution.simps)
    moreover from sc have "sequentially_consistent (J2JVM P) (E, ws)"
      by(simp add: J2JVM_def compP2_def)
    moreover from conflict have "J2JVM P,E  a  a'"
      by(simp add: J2JVM_def compP2_def)
    ultimately have "J2JVM P,E  a ≤hb a'  J2JVM P,E  a' ≤hb a"
      using ?lhs actions by(auto simp add: correctly_synchronized_def)
    thus "P,E  a ≤hb a'  P,E  a' ≤hb a"
      by(simp add: J2JVM_def compP2_def)
  qed
next
  assume ?rhs
  show ?lhs unfolding correctly_synchronized_def
  proof(intro strip)
    fix E ws a a'
    assume E: "E  jmm_JVMd_ℰ (J2JVM P) C M vs Running"
      and wf_exec: "J2JVM P  (E, ws) "
      and sc: "sequentially_consistent (J2JVM P) (E, ws)"
      and actions: "a  actions E" "a'  actions E"
      and conflict: "J2JVM P,E  a  a'"

    from wf have "wf_jvm_prog (J2JVM P)" by(rule wt_J2JVM)
    then obtain Φ where wf': "wf_jvm_progΦ (J2JVM P)"
      by(auto simp add: wf_jvm_prog_def)
    from wf_start have wf_start': "jmm_wf_start_state (J2JVM P) C M vs"
      by(simp add: J2JVM_def compP2_def heap_base.wf_start_state_compP)
    from E wf_exec sc
    have "legal_execution (J2JVM P) (jmm_JVMd_ℰ (J2JVM P) C M vs Running) (E, ws)"
      by(rule sc_legal.SC_is_legal[OF JVM_allocated_progress.JVM_sc_legal[OF jmm_JVM_allocated_progress wf' jmm_heap_read_typeable wf_start' ka]])
    hence "legal_execution P (jmm_J_ℰ P C M vs Running) (E, ws)"
      by(simp only: J2JVM_jmm_correct[OF wf wf_start])
    hence "E  jmm_J_ℰ P C M vs Running" "P  (E, ws) "
      by(simp_all add: gen_legal_execution.simps)
    moreover from sc have "sequentially_consistent P (E, ws)"
      by(simp add: J2JVM_def compP2_def)
    moreover from conflict have "P,E  a  a'"
      by(simp add: J2JVM_def compP2_def)
    ultimately have "P,E  a ≤hb a'  P,E  a' ≤hb a"
      using ?rhs actions by(auto simp add: correctly_synchronized_def)
    thus "J2JVM P,E  a ≤hb a'  J2JVM P,E  a' ≤hb a" 
      by(simp add: J2JVM_def compP2_def)
  qed
qed

end

Theory JMM

(*  Title:      JinjaThreads/MM/JMM.thy
    Author:     Andreas Lochbihler
*)

theory JMM
imports
  JMM_DRF
  SC_Legal
  DRF_J
  DRF_JVM
  JMM_Type
  JMM_Interp
  JMM_Typesafe
  JMM_J_Typesafe
  JMM_JVM_Typesafe
  JMM_Compiler_Type2
begin

end

Theory MM_Main

theory MM_Main
imports
  SC
  SC_Interp
  SC_Collections
  JMM
begin

end

Theory State_Refinement

(*  Title:      JinjaThreads/Execute/State_Refinement.thy
    Author:     Andreas Lochbihler
*)

chapter ‹Schedulers›

section ‹Refinement for multithreaded states›

theory State_Refinement
imports
  "../Framework/FWSemantics"
  "../Common/StartConfig"
begin

type_synonym
  ('l,'t,'m,'m_t,'m_w,'s_i) state_refine = "('l,'t) locks × ('m_t × 'm) × 'm_w × 's_i"

locale state_refine_base =
  fixes final :: "'x  bool"
  and r :: "'t  ('x × 'm)  (('l,'t,'x,'m,'w,'o) thread_action × 'x × 'm) Predicate.pred"
  and convert_RA :: "'l released_locks  'o list"
  and thr_α :: "'m_t  ('l,'t,'x) thread_info"
  and thr_invar :: "'m_t  bool"
  and ws_α :: "'m_w  ('w,'t) wait_sets"
  and ws_invar :: "'m_w  bool"
  and is_α :: "'s_i  't interrupts"
  and is_invar :: "'s_i  bool"
begin

fun state_α :: "('l,'t,'m,'m_t,'m_w, 's_i) state_refine  ('l,'t,'x,'m,'w) state"
where "state_α (ls, (ts, m), ws, is) = (ls, (thr_α ts, m), ws_α ws, is_α is)"

lemma state_α_conv [simp]:
  "locks (state_α s) = locks s"
  "thr (state_α s) = thr_α (thr s)"
  "shr (state_α s) = shr s"
  "wset (state_α s) = ws_α (wset s)"
  "interrupts (state_α s) = is_α (interrupts s)"
by(case_tac [!] s) auto

inductive state_invar :: "('l,'t,'m,'m_t,'m_w,'s_i) state_refine  bool"
where " thr_invar ts; ws_invar ws; is_invar is   state_invar (ls, (ts, m), ws, is)"

inductive_simps state_invar_simps [simp]:
  "state_invar (ls, (ts, m), ws, is)"

lemma state_invarD [simp]:
  assumes "state_invar s"
  shows "thr_invar (thr s)" "ws_invar (wset s)" "is_invar (interrupts s)"
using assms by(case_tac [!] s) auto

end

sublocale state_refine_base < α: final_thread final .
sublocale state_refine_base < α:
  multithreaded_base
    final
    "λt xm ta x'm'. Predicate.eval (r t xm) (ta, x'm')"
.

definition (in heap_base) start_state_refine :: 
  "'m_t  ('thread_id  ('x × 'addr released_locks)  'm_t  'm_t)  'm_w  's_i
   (cname  mname  ty list  ty  'md  'addr val list  'x)  'md prog  cname  mname  'addr val list
   ('addr, 'thread_id, 'heap, 'm_t, 'm_w, 's_i) state_refine"
where
  "is_empty.
  start_state_refine thr_empty thr_update ws_empty is_empty f P C M vs =
  (let (D, Ts, T, m) = method P C M
   in (K$ None, (thr_update start_tid (f D M Ts T (the m) vs, no_wait_locks) thr_empty, start_heap), ws_empty, is_empty))"

definition Jinja_output :: 
  "'s  'thread_id  ('addr, 'thread_id, 'x, 'heap, 'addr, ('addr, 'thread_id) obs_event) thread_action 
   ('thread_id × ('addr, 'thread_id) obs_event list) option"
where "Jinja_output σ t ta = (if tao = [] then None else Some (t, tao))"

lemmas [code] =
  heap_base.start_state_refine_def

end

Theory Scheduler

(*  Title:      JinjaThreads/Execute/Scheduler.thy
    Author:     Andreas Lochbihler
*)

section ‹Abstract scheduler›

theory Scheduler
imports
  State_Refinement
  "../Framework/FWProgressAux"
  "../Framework/FWLTS"
  (*"../../Collections/spec/SetSpec"
  "../../Collections/spec/MapSpec"
  "../../Collections/spec/ListSpec"*)
  "../Basic/JT_ICF"

begin

text ‹
  Define an unfold operation that puts everything into one function to avoid duplicate evaluation.
›

definition unfold_tllist' :: "('a  'b × 'a + 'c)  'a  ('b, 'c) tllist"
where [code del]: 
  "unfold_tllist' f = 
   unfold_tllist (λa. c. f a = Inr c) (projr  f) (fst  projl  f) (snd  projl  f)"

lemma unfold_tllist' [code]:
  "unfold_tllist' f a =
  (case f a of Inr c  TNil c | Inl (b, a')  TCons b (unfold_tllist' f a'))"
by(rule tllist.expand)(auto simp add: unfold_tllist'_def split: sum.split_asm)


type_synonym
  ('l,'t,'x,'m,'w,'o,'m_t,'m_w,'s_i,'s) scheduler = 
    "'s  ('l,'t,'m,'m_t,'m_w,'s_i) state_refine  ('t × (('l,'t,'x,'m,'w,'o) thread_action × 'x × 'm) option × 's) option"

locale scheduler_spec_base =
  state_refine_base
    final r convert_RA
    thr_α thr_invar
    ws_α ws_invar 
    is_α is_invar
  for final :: "'x  bool"
  and r :: "'t  ('x × 'm)  (('l,'t,'x,'m,'w,'o) thread_action × 'x × 'm) Predicate.pred"
  and convert_RA :: "'l released_locks  'o list"
  and schedule :: "('l,'t,'x,'m,'w,'o,'m_t,'m_w,'s_i,'s) scheduler"
  and σ_invar :: "'s  't set  bool"
  and thr_α :: "'m_t  ('l,'t,'x) thread_info"
  and thr_invar :: "'m_t  bool"
  and ws_α :: "'m_w  ('w,'t) wait_sets"
  and ws_invar :: "'m_w  bool"
  and is_α :: "'s_i  't interrupts"
  and is_invar :: "'s_i  bool"

locale scheduler_spec = 
  scheduler_spec_base
    final r convert_RA
    schedule σ_invar
    thr_α thr_invar
    ws_α ws_invar 
    is_α is_invar
  for final :: "'x  bool"
  and r :: "'t  ('x × 'm)  (('l,'t,'x,'m,'w,'o) thread_action × 'x × 'm) Predicate.pred"
  and convert_RA :: "'l released_locks  'o list"
  and schedule :: "('l,'t,'x,'m,'w,'o,'m_t,'m_w,'s_i,'s) scheduler"
  and σ_invar :: "'s  't set  bool"
  and thr_α :: "'m_t  ('l,'t,'x) thread_info"
  and thr_invar :: "'m_t  bool"
  and ws_α :: "'m_w  ('w,'t) wait_sets"
  and ws_invar :: "'m_w  bool"
  and is_α :: "'s_i  't interrupts"
  and is_invar :: "'s_i  bool"
  +
  fixes invariant :: "('l,'t,'x,'m,'w) state set"
  assumes schedule_NoneD:
  " schedule σ s = None; state_invar s; σ_invar σ (dom (thr_α (thr s))); state_α s  invariant 
   α.active_threads (state_α s) = {}"
  and schedule_Some_NoneD:
  " schedule σ s = (t, None, σ'); state_invar s; σ_invar σ (dom (thr_α (thr s))); state_α s  invariant  
   x ln n. thr_α (thr s) t = (x, ln)  ln $ n > 0  ¬ waiting (ws_α (wset s) t)  may_acquire_all (locks s) t ln"
  and schedule_Some_SomeD:
  " schedule σ s = (t, (ta, x', m'), σ'); state_invar s; σ_invar σ (dom (thr_α (thr s))); state_α s  invariant  
   x. thr_α (thr s) t = (x, no_wait_locks)  Predicate.eval (r t (x, shr s)) (ta, x', m')  
         α.actions_ok (state_α s) t ta"
  and schedule_invar_None:
  " schedule σ s = (t, None, σ'); state_invar s; σ_invar σ (dom (thr_α (thr s))); state_α s  invariant 
   σ_invar σ' (dom (thr_α (thr s)))"
  and schedule_invar_Some:
  " schedule σ s = (t, (ta, x', m'), σ'); state_invar s; σ_invar σ (dom (thr_α (thr s))); state_α s  invariant 
   σ_invar σ' (dom (thr_α (thr s))  {t. x m. NewThread t x m  set tat})"

locale pick_wakeup_spec_base =
  state_refine_base
    final r convert_RA
    thr_α thr_invar
    ws_α ws_invar 
    is_α is_invar
  for final :: "'x  bool"
  and r :: "'t  ('x × 'm)  (('l,'t,'x,'m,'w,'o) thread_action × 'x × 'm) Predicate.pred"
  and convert_RA :: "'l released_locks  'o list"
  and pick_wakeup :: "'s  't  'w  'm_w  't option"
  and σ_invar :: "'s  't set  bool"
  and thr_α :: "'m_t  ('l,'t,'x) thread_info"
  and thr_invar :: "'m_t  bool"
  and ws_α :: "'m_w  ('w,'t) wait_sets"
  and ws_invar :: "'m_w  bool"
  and is_α :: "'s_i  't interrupts"
  and is_invar :: "'s_i  bool"

locale pick_wakeup_spec =
  pick_wakeup_spec_base 
    final r convert_RA
    pick_wakeup σ_invar
    thr_α thr_invar
    ws_α ws_invar
    is_α is_invar
  for final :: "'x  bool"
  and r :: "'t  ('x × 'm)  (('l,'t,'x,'m,'w,'o) thread_action × 'x × 'm) Predicate.pred"
  and convert_RA :: "'l released_locks  'o list"
  and pick_wakeup :: "'s  't  'w  'm_w  't option"
  and σ_invar :: "'s  't set  bool"
  and thr_α :: "'m_t  ('l,'t,'x) thread_info"
  and thr_invar :: "'m_t  bool"
  and ws_α :: "'m_w  ('w,'t) wait_sets"
  and ws_invar :: "'m_w  bool"
  and is_α :: "'s_i  't interrupts"
  and is_invar :: "'s_i  bool"
  +
  assumes pick_wakeup_NoneD:
  " pick_wakeup σ t w ws = None; ws_invar ws; σ_invar σ T; dom (ws_α ws)  T; t  T  
   InWS w  ran (ws_α ws)"
  and pick_wakeup_SomeD:
  " pick_wakeup σ t w ws = t'; ws_invar ws; σ_invar σ T; dom (ws_α ws)  T; t  T 
   ws_α ws t' = InWS w"

locale scheduler_base_aux =
  state_refine_base
    final r convert_RA
    thr_α thr_invar
    ws_α ws_invar
    is_α is_invar
  for final :: "'x  bool"
  and r :: "'t  ('x × 'm)  (('l,'t,'x,'m,'w,'o) thread_action × 'x × 'm) Predicate.pred"
  and convert_RA :: "'l released_locks  'o list"
  and thr_α :: "'m_t  ('l,'t,'x) thread_info"
  and thr_invar :: "'m_t  bool"
  and thr_lookup :: "'t  'm_t  ('x × 'l released_locks)"
  and thr_update :: "'t  'x × 'l released_locks  'm_t  'm_t"
  and ws_α :: "'m_w  ('w,'t) wait_sets"
  and ws_invar :: "'m_w  bool"
  and ws_lookup :: "'t  'm_w  'w wait_set_status"
  and is_α :: "'s_i  't interrupts"
  and is_invar :: "'s_i  bool"
  and is_memb :: "'t  's_i  bool"
  and is_ins :: "'t  's_i  's_i"
  and is_delete :: "'t  's_i  's_i"
begin

definition free_thread_id :: "'m_t  't  bool"
where "free_thread_id ts t  thr_lookup t ts = None"

fun redT_updT :: "'m_t  ('t,'x,'m) new_thread_action  'm_t"
where
  "redT_updT ts (NewThread t' x m) = thr_update t' (x, no_wait_locks) ts"
| "redT_updT ts _ = ts"

definition redT_updTs :: "'m_t  ('t,'x,'m) new_thread_action list  'm_t"
where "redT_updTs = foldl redT_updT"

primrec thread_ok :: "'m_t  ('t,'x,'m) new_thread_action  bool"
where
  "thread_ok ts (NewThread t x m) = free_thread_id ts t"
| "thread_ok ts (ThreadExists t b) = (b  free_thread_id ts t)"

text ‹
  We use @{term "redT_updT"} in thread_ok› instead of @{term "redT_updT'"} like in theory @{theory JinjaThreads.FWThread}.
  This fixes @{typ "'x"} in the @{typ "('t,'x,'m) new_thread_action list"} type, but avoids @{term "undefined"},
  which raises an exception during execution in the generated code.
›

primrec thread_oks :: "'m_t  ('t,'x,'m) new_thread_action list  bool"
where
  "thread_oks ts [] = True"
| "thread_oks ts (ta#tas) = (thread_ok ts ta  thread_oks (redT_updT ts ta) tas)"

definition wset_actions_ok :: "'m_w  't  ('t,'w) wait_set_action list  bool"
where
  "wset_actions_ok ws t was 
   ws_lookup t ws = 
   (if Notified  set was then PostWS WSNotified
    else if WokenUp  set was then PostWS WSWokenUp
    else None)"

primrec cond_action_ok :: "('l,'t,'m,'m_t,'m_w,'s_i) state_refine  't  't conditional_action  bool" 
where
  "ln. cond_action_ok s t (Join T) = 
   (case thr_lookup T (thr s)
      of None  True 
    | (x, ln)  t  T  final x  ln = no_wait_locks  ws_lookup T (wset s) = None)"
| "cond_action_ok s t Yield = True"

definition cond_action_oks :: "('l,'t,'m,'m_t,'m_w,'s_i) state_refine  't  't conditional_action list  bool" 
where
  "cond_action_oks s t cts = list_all (cond_action_ok s t) cts"

primrec redT_updI :: "'s_i  't interrupt_action  's_i"
where
  "redT_updI is (Interrupt t) = is_ins t is"
| "redT_updI is (ClearInterrupt t) = is_delete t is"
| "redT_updI is (IsInterrupted t b) = is"

primrec redT_updIs :: "'s_i  't interrupt_action list  's_i"
where
  "redT_updIs is [] = is"
| "redT_updIs is (ia # ias) = redT_updIs (redT_updI is ia) ias"

primrec interrupt_action_ok :: "'s_i  't interrupt_action  bool"
where
  "interrupt_action_ok is (Interrupt t) = True"
| "interrupt_action_ok is (ClearInterrupt t) = True"
| "interrupt_action_ok is (IsInterrupted t b) = (b = (is_memb t is))"

primrec interrupt_actions_ok :: "'s_i  't interrupt_action list  bool"
where
  "interrupt_actions_ok is [] = True"
| "interrupt_actions_ok is (ia # ias)  interrupt_action_ok is ia  interrupt_actions_ok (redT_updI is ia) ias"

definition actions_ok :: "('l,'t,'m,'m_t,'m_w,'s_i) state_refine  't  ('l,'t,'x,'m,'w,'o') thread_action  bool"
where
  "actions_ok s t ta 
   lock_ok_las (locks s) t tal  
   thread_oks (thr s) tat 
   cond_action_oks s t tac 
   wset_actions_ok (wset s) t taw 
   interrupt_actions_ok (interrupts s) tai"

end

locale scheduler_base =
  scheduler_base_aux
    final r convert_RA
    thr_α thr_invar thr_lookup thr_update
    ws_α ws_invar ws_lookup
    is_α is_invar is_memb is_ins is_delete
  +
  scheduler_spec_base
    final r convert_RA
    schedule σ_invar
    thr_α thr_invar
    ws_α ws_invar 
    is_α is_invar
  +
  pick_wakeup_spec_base
    final r convert_RA
    pick_wakeup σ_invar
    thr_α thr_invar
    ws_α ws_invar
    is_α is_invar
  for final :: "'x  bool"
  and r :: "'t  ('x × 'm)  (('l,'t,'x,'m,'w,'o) thread_action × 'x × 'm) Predicate.pred"
  and convert_RA :: "'l released_locks  'o list"
  and schedule :: "('l,'t,'x,'m,'w,'o,'m_t,'m_w,'s_i,'s) scheduler"
  and "output" :: "'s  't  ('l,'t,'x,'m,'w,'o) thread_action  'q option"
  and pick_wakeup :: "'s  't  'w  'm_w  't option"
  and σ_invar :: "'s  't set  bool"
  and thr_α :: "'m_t  ('l,'t,'x) thread_info"
  and thr_invar :: "'m_t  bool"
  and thr_lookup :: "'t  'm_t  ('x × 'l released_locks)"
  and thr_update :: "'t  'x × 'l released_locks  'm_t  'm_t"
  and ws_α :: "'m_w  ('w,'t) wait_sets"
  and ws_invar :: "'m_w  bool"
  and ws_lookup :: "'t  'm_w  'w wait_set_status"
  and ws_update :: "'t  'w wait_set_status  'm_w  'm_w"
  and ws_delete :: "'t  'm_w  'm_w"
  and ws_iterate :: "'m_w  ('t × 'w wait_set_status, 'm_w) set_iterator"
  and is_α :: "'s_i  't interrupts"
  and is_invar :: "'s_i  bool"
  and is_memb :: "'t  's_i  bool"
  and is_ins :: "'t  's_i  's_i"
  and is_delete :: "'t  's_i  's_i"
begin

primrec exec_updW :: "'s  't  'm_w  ('t,'w) wait_set_action  'm_w"
where
  "exec_updW σ t ws (Notify w) = 
   (case pick_wakeup σ t w ws
    of None   ws
    | Some t  ws_update t (PostWS WSNotified) ws)"
| "exec_updW σ t ws (NotifyAll w) =
   ws_iterate ws (λ_. True) (λ(t, w') ws'. if w' = InWS w then ws_update t (PostWS WSNotified) ws' else ws') 
              ws"
| "exec_updW σ t ws (Suspend w) = ws_update t (InWS w) ws"
| "exec_updW σ t ws (WakeUp t') =
   (case ws_lookup t' ws of InWS w  ws_update t' (PostWS WSWokenUp) ws | _  ws)"
| "exec_updW σ t ws Notified = ws_delete t ws"
| "exec_updW σ t ws WokenUp = ws_delete t ws"

definition exec_updWs :: "'s  't  'm_w  ('t,'w) wait_set_action list  'm_w"
where "exec_updWs σ t = foldl (exec_updW σ t)"

definition exec_upd ::
  "'s  ('l,'t,'m,'m_t,'m_w,'s_i) state_refine  't  ('l,'t,'x,'m,'w,'o) thread_action  'x  'm
   ('l,'t,'m,'m_t,'m_w,'s_i) state_refine"
where [simp]:
  "exec_upd σ s t ta x' m' =
   (redT_updLs (locks s) t tal,
    (thr_update t (x', redT_updLns (locks s) t (snd (the (thr_lookup t (thr s)))) tal) (redT_updTs (thr s) tat), m'),
    exec_updWs σ t (wset s) taw, redT_updIs (interrupts s) tai)"

definition execT :: 
  "'s  ('l,'t,'m,'m_t,'m_w,'s_i) state_refine
   ('s × 't × ('l,'t,'x,'m,'w,'o) thread_action × ('l,'t,'m,'m_t,'m_w,'s_i) state_refine) option"
where 
  "execT σ s =
  (do {
     (t, tax'm', σ')  schedule σ s;
     case tax'm' of
       None  
       (let (x, ln) = the (thr_lookup t (thr s));
            ta = (K$ [], [], [], [], [], convert_RA ln);
            s' = (acquire_all (locks s) t ln, (thr_update t (x, no_wait_locks) (thr s), shr s), wset s, interrupts s)
        in (σ', t, ta, s'))
     | (ta, x', m')  (σ', t, ta, exec_upd σ s t ta x' m')
   })"

primrec exec_step :: 
  "'s × ('l,'t,'m,'m_t,'m_w,'s_i) state_refine  
   ('s × 't × ('l,'t,'x,'m,'w,'o) thread_action) × 's × ('l,'t,'m,'m_t,'m_w,'s_i) state_refine + ('l,'t,'m,'m_t,'m_w,'s_i) state_refine"
where
  "exec_step (σ, s) =
   (case execT σ s of 
      None  Inr s
    | Some (σ', t, ta, s')  Inl ((σ, t, ta), σ', s'))"

declare exec_step.simps [simp del]

definition exec_aux ::
  "'s × ('l,'t,'m,'m_t,'m_w,'s_i) state_refine
   ('s × 't × ('l,'t,'x,'m,'w,'o) thread_action, ('l,'t,'m,'m_t,'m_w,'s_i) state_refine) tllist"
where
  "exec_aux σs = unfold_tllist' exec_step σs"

definition exec :: "'s  ('l,'t,'m,'m_t,'m_w,'s_i) state_refine  ('q, ('l,'t,'m,'m_t,'m_w,'s_i) state_refine) tllist"
where 
  "exec σ s = tmap the id (tfilter undefined (λq. q  None) (tmap (λ(σ, t, ta). output σ t ta) id (exec_aux (σ, s))))"

end

text ‹
  Implement pick_wakeup› by map_sel'›

definition pick_wakeup_via_sel :: 
  "('m_w  ('t  'w wait_set_status  bool)  't × 'w wait_set_status) 
   's  't  'w  'm_w  't option"
where "pick_wakeup_via_sel ws_sel σ t w ws = map_option fst (ws_sel ws (λt w'. w' = InWS w))"

lemma pick_wakeup_spec_via_sel:
  assumes sel: "map_sel' ws_α ws_invar ws_sel"
  shows "pick_wakeup_spec (pick_wakeup_via_sel (λs P. ws_sel s (λ(k,v). P k v))) σ_invar ws_α ws_invar"
proof -
  interpret ws: map_sel' ws_α ws_invar ws_sel by(rule sel)
  show ?thesis
    by(unfold_locales)(auto simp add: pick_wakeup_via_sel_def ran_def dest: ws.sel'_noneD ws.sel'_SomeD)
qed

locale scheduler_ext_base =
  scheduler_base_aux
    final r convert_RA
    thr_α thr_invar thr_lookup thr_update
    ws_α ws_invar ws_lookup
    is_α is_invar is_memb is_ins is_delete
  for final :: "'x  bool"
  and r :: "'t  ('x × 'm)  (('l,'t,'x,'m,'w,'o) thread_action × 'x × 'm) Predicate.pred"
  and convert_RA :: "'l released_locks  'o list"
  and thr_α :: "'m_t  ('l,'t,'x) thread_info"
  and thr_invar :: "'m_t  bool"
  and thr_lookup :: "'t  'm_t  ('x × 'l released_locks)"
  and thr_update :: "'t  'x × 'l released_locks  'm_t  'm_t"
  and thr_iterate :: "'m_t  ('t × ('x × 'l released_locks), 's_t) set_iterator"
  and ws_α :: "'m_w  ('w,'t) wait_sets"
  and ws_invar :: "'m_w  bool"
  and ws_lookup :: "'t  'm_w  'w wait_set_status"
  and ws_update :: "'t  'w wait_set_status  'm_w  'm_w"
  and ws_sel :: "'m_w  ('t × 'w wait_set_status  bool)  ('t × 'w wait_set_status)"
  and is_α :: "'s_i  't interrupts"
  and is_invar :: "'s_i  bool"
  and is_memb :: "'t  's_i  bool"
  and is_ins :: "'t  's_i  's_i"
  and is_delete :: "'t  's_i  's_i"
  +
  fixes thr'_α :: "'s_t  't set"
  and thr'_invar :: "'s_t  bool"
  and thr'_empty :: "unit  's_t"
  and thr'_ins_dj :: "'t  's_t  's_t"
begin

abbreviation pick_wakeup :: "'s  't  'w  'm_w  't option"
where "pick_wakeup  pick_wakeup_via_sel (λs P. ws_sel s (λ(k,v). P k v))"

fun active_threads :: "('l,'t,'m,'m_t,'m_w,'s_i) state_refine  's_t"
where
  "active_threads (ls, (ts, m), ws, is) =
   thr_iterate ts (λ_. True)
      (λ(t, (x, ln)) ts'. if ln = no_wait_locks
                       then if Predicate.holds 
                               (do {
                                  (ta, _)  r t (x, m);
                                  Predicate.if_pred (actions_ok (ls, (ts, m), ws, is) t ta)
                                })
                            then thr'_ins_dj t ts'
                            else ts'
                       else if ¬ waiting (ws_lookup t ws)  may_acquire_all ls t ln then thr'_ins_dj t ts' else ts')
      (thr'_empty ())"

end

locale scheduler_aux =
  scheduler_base_aux
    final r convert_RA
    thr_α thr_invar thr_lookup thr_update
    ws_α ws_invar ws_lookup
    is_α is_invar is_memb is_ins is_delete
  +
  thr: finite_map thr_α thr_invar +
  thr: map_lookup thr_α thr_invar thr_lookup +
  thr: map_update thr_α thr_invar thr_update +
  ws: map ws_α ws_invar +
  ws: map_lookup ws_α ws_invar ws_lookup +
  "is": set is_α is_invar +
  "is": set_memb is_α is_invar is_memb +
  "is": set_ins is_α is_invar is_ins +
  "is": set_delete is_α is_invar is_delete
  for final :: "'x  bool"
  and r :: "'t  ('x × 'm)  (('l,'t,'x,'m,'w,'o) thread_action × 'x × 'm) Predicate.pred"
  and convert_RA :: "'l released_locks  'o list"
  and thr_α :: "'m_t  ('l,'t,'x) thread_info"
  and thr_invar :: "'m_t  bool"
  and thr_lookup :: "'t  'm_t  ('x × 'l released_locks)"
  and thr_update :: "'t  'x × 'l released_locks  'm_t  'm_t"
  and ws_α :: "'m_w  ('w,'t) wait_sets"
  and ws_invar :: "'m_w  bool"
  and ws_lookup :: "'t  'm_w  'w wait_set_status"
  and is_α :: "'s_i  't interrupts"
  and is_invar :: "'s_i  bool"
  and is_memb :: "'t  's_i  bool"
  and is_ins :: "'t  's_i  's_i"
  and is_delete :: "'t  's_i  's_i"
begin

lemma free_thread_id_correct [simp]:
  "thr_invar ts  free_thread_id ts = FWThread.free_thread_id (thr_α ts)"
by(auto simp add: free_thread_id_def fun_eq_iff thr.lookup_correct intro: free_thread_id.intros)

lemma redT_updT_correct [simp]:
  assumes "thr_invar ts"
  shows "thr_α (redT_updT ts nta) = FWThread.redT_updT (thr_α ts) nta"
  and "thr_invar (redT_updT ts nta)"
by(case_tac [!] nta)(simp_all add: thr.update_correct assms)

lemma redT_updTs_correct [simp]:
  assumes  "thr_invar ts"
  shows "thr_α (redT_updTs ts ntas) = FWThread.redT_updTs (thr_α ts) ntas"
  and "thr_invar (redT_updTs ts ntas)"
using assms
by(induct ntas arbitrary: ts)(simp_all add: redT_updTs_def)

lemma thread_ok_correct [simp]:
  "thr_invar ts  thread_ok ts nta  FWThread.thread_ok (thr_α ts) nta"
by(cases nta) simp_all

lemma thread_oks_correct [simp]:
  "thr_invar ts  thread_oks ts ntas  FWThread.thread_oks (thr_α ts) ntas"
by(induct ntas arbitrary: ts) simp_all

lemma wset_actions_ok_correct [simp]:
  "ws_invar ws  wset_actions_ok ws t was  FWWait.wset_actions_ok (ws_α ws) t was"
by(simp add: wset_actions_ok_def FWWait.wset_actions_ok_def ws.lookup_correct)

lemma cond_action_ok_correct [simp]:
  "state_invar s  cond_action_ok s t cta  α.cond_action_ok (state_α s) t cta"
by(cases s,cases cta)(auto simp add: thr.lookup_correct ws.lookup_correct)

lemma cond_action_oks_correct [simp]:
  assumes "state_invar s"
  shows "cond_action_oks s t ctas  α.cond_action_oks (state_α s) t ctas"
by(induct ctas)(simp_all add: cond_action_oks_def assms)

lemma redT_updI_correct [simp]:
  assumes "is_invar is"
  shows "is_α (redT_updI is ia) = FWInterrupt.redT_updI (is_α is) ia"
  and "is_invar (redT_updI is ia)"
using assms
by(case_tac [!] ia)(auto simp add: is.ins_correct is.delete_correct)

lemma redT_updIs_correct [simp]:
  assumes "is_invar is"
  shows "is_α (redT_updIs is ias) = FWInterrupt.redT_updIs (is_α is) ias"
  and "is_invar (redT_updIs is ias)"
using assms
by(induct ias arbitrary: "is")(auto)

lemma interrupt_action_ok_correct [simp]:
  "is_invar is  interrupt_action_ok is ia  FWInterrupt.interrupt_action_ok (is_α is) ia"
by(cases ia)(auto simp add: is.memb_correct)

lemma interrupt_actions_ok_correct [simp]:
  "is_invar is  interrupt_actions_ok is ias  FWInterrupt.interrupt_actions_ok (is_α is) ias"
by(induct ias arbitrary:"is") simp_all

lemma actions_ok_correct [simp]:
  "state_invar s  actions_ok s t ta  α.actions_ok (state_α s) t ta"
by(auto simp add: actions_ok_def)

end

locale scheduler =
  scheduler_base 
    final r convert_RA
    schedule "output" pick_wakeup σ_invar
    thr_α thr_invar thr_lookup thr_update
    ws_α ws_invar ws_lookup ws_update ws_delete ws_iterate
    is_α is_invar is_memb is_ins is_delete
  +
  scheduler_aux
    final r convert_RA
    thr_α thr_invar thr_lookup thr_update
    ws_α ws_invar ws_lookup
    is_α is_invar is_memb is_ins is_delete
  +
  scheduler_spec
    final r convert_RA
    schedule σ_invar
    thr_α thr_invar
    ws_α ws_invar
    is_α is_invar
    invariant
  +
  pick_wakeup_spec
    final r convert_RA
    pick_wakeup σ_invar
    thr_α thr_invar
    ws_α ws_invar
    is_α is_invar
  +
  ws: map_update ws_α ws_invar ws_update +
  ws: map_delete ws_α ws_invar ws_delete +
  ws: map_iteratei ws_α ws_invar ws_iterate 
  for final :: "'x  bool"
  and r :: "'t  ('x × 'm)  (('l,'t,'x,'m,'w,'o) thread_action × 'x × 'm) Predicate.pred"
  and convert_RA :: "'l released_locks  'o list"
  and schedule :: "('l,'t,'x,'m,'w,'o,'m_t,'m_w,'s_i,'s) scheduler"
  and "output" :: "'s  't  ('l,'t,'x,'m,'w,'o) thread_action  'q option"
  and pick_wakeup :: "'s  't  'w  'm_w  't option"
  and σ_invar :: "'s  't set  bool"
  and thr_α :: "'m_t  ('l,'t,'x) thread_info"
  and thr_invar :: "'m_t  bool"
  and thr_lookup :: "'t  'm_t  ('x × 'l released_locks)"
  and thr_update :: "'t  'x × 'l released_locks  'm_t  'm_t"
  and ws_α :: "'m_w  ('w,'t) wait_sets"
  and ws_invar :: "'m_w  bool"
  and ws_lookup :: "'t  'm_w  'w wait_set_status"
  and ws_update :: "'t  'w wait_set_status  'm_w  'm_w"
  and ws_delete :: "'t  'm_w  'm_w"
  and ws_iterate :: "'m_w  ('t × 'w wait_set_status, 'm_w) set_iterator"
  and is_α :: "'s_i  't interrupts"
  and is_invar :: "'s_i  bool"
  and is_memb :: "'t  's_i  bool"
  and is_ins :: "'t  's_i  's_i"
  and is_delete :: "'t  's_i  's_i"
  and invariant :: "('l,'t,'x,'m,'w) state set"
  +
  assumes invariant: "invariant3p α.redT invariant"
begin

lemma exec_updW_correct:
  assumes invar: "ws_invar ws" "σ_invar σ T" "dom (ws_α ws)  T" "t  T"
  shows "redT_updW t (ws_α ws) wa (ws_α (exec_updW σ t ws wa))" (is "?thesis1")
  and "ws_invar (exec_updW σ t ws wa)" (is "?thesis2")
proof -
  from invar have "?thesis1  ?thesis2"
  proof(cases wa)
    case [simp]: (Notify w)
    show ?thesis
    proof(cases "pick_wakeup σ t w ws")
      case (Some t')
      hence "ws_α ws t' = InWS w" using invar by(rule pick_wakeup_SomeD)
      with Some show ?thesis using invar by(auto simp add: ws.update_correct)
    next
      case None
      hence "InWS w  ran (ws_α ws)" using invar by(rule pick_wakeup_NoneD)
      with None show ?thesis using invar by(auto simp add: ran_def)
    qed
  next
    case [simp]: (NotifyAll w)
    let ?f = "λ(t, w') ws'. if w' = InWS w then ws_update t (PostWS WSNotified) ws' else ws'"
    let ?I = "λT ws'. (k. if kT  ws_α ws k = InWS w then ws_α ws' k = PostWS WSNotified else ws_α ws' k = ws_α ws k)  ws_invar ws'"
    from invar have "?I (dom (ws_α ws)) ws" by(auto simp add: ws.lookup_correct)
    with ws_invar ws have "?I {} (ws_iterate ws (λ_. True) ?f ws)"
    proof(rule ws.iterate_rule_P[where I="?I"])
      fix t w' T ws'
      assume t: "t  T" and w': "ws_α ws t = w'"
        and T: "T  dom (ws_α ws)" and I: "?I T ws'"
      { fix t'
        assume "t'  T - {t}" "ws_α ws t' = InWS w"
        with t I w' invar have "ws_α (?f (t, w') ws') t' = PostWS WSNotified"
          by(auto)(simp_all add: ws.update_correct) }
      moreover {
        fix t'
        assume "t'  T - {t}  ws_α ws t'  InWS w"
        with t I w' invar have "ws_α (?f (t,w') ws') t' = ws_α ws t'"
          by(auto simp add: ws.update_correct) }
      moreover
      have "ws_invar (?f (t, w') ws')" using I by(simp add: ws.update_correct)
      ultimately show "?I (T - {t}) (?f (t, w') ws')" by safe simp
    qed
    hence "ws_α (ws_iterate ws (λ_. True) ?f ws) = (λt. if ws_α ws t = InWS w then PostWS WSNotified else ws_α ws t)"
      and "ws_invar (ws_iterate ws (λ_. True) ?f ws)" by(simp_all add: fun_eq_iff)
    thus ?thesis by simp
  next
    case WakeUp thus ?thesis using assms
      by(auto simp add: ws.lookup_correct ws.update_correct split: wait_set_status.split)
  qed(simp_all add: ws.update_correct ws.delete_correct map_upd_eq_restrict)
  thus ?thesis1 ?thesis2 by simp_all
qed

lemma exec_updWs_correct:
  assumes "ws_invar ws" "σ_invar σ T" "dom (ws_α ws)  T" "t  T"
  shows "redT_updWs t (ws_α ws) was (ws_α (exec_updWs σ t ws was))" (is "?thesis1")
  and "ws_invar (exec_updWs σ t ws was)" (is "?thesis2")
proof -
  from ws_invar ws ‹dom (ws_α ws)  T 
  have "?thesis1  ?thesis2"
  proof(induct was arbitrary: ws)
    case Nil thus ?case by(auto simp add: exec_updWs_def redT_updWs_def)
  next
    case (Cons wa was)
    let ?ws' = "exec_updW σ t ws wa"
    from ws_invar ws σ_invar σ T ‹dom (ws_α ws)  T t  T
    have invar': "ws_invar ?ws'" and red: "redT_updW t (ws_α ws) wa (ws_α ?ws')"
      by(rule exec_updW_correct)+
    have "dom (ws_α ?ws')  T"
    proof
      fix t' assume "t'  dom (ws_α ?ws')"
      with red have "t'  dom (ws_α ws)  t = t'"
        by(auto dest!: redT_updW_Some_otherD split: wait_set_status.split_asm)
      with ‹dom (ws_α ws)  T t  T show "t'  T" by auto
    qed
    with invar' have "redT_updWs t (ws_α ?ws') was (ws_α (exec_updWs σ t ?ws' was))  ws_invar (exec_updWs σ t ?ws' was)"
      by(rule Cons.hyps)
    thus ?case using red
      by(auto simp add: exec_updWs_def redT_updWs_def intro: rtrancl3p_step_converse)
  qed
  thus ?thesis1 ?thesis2 by simp_all
qed

lemma exec_upd_correct:
  assumes "state_invar s" "σ_invar σ (dom (thr_α (thr s)))" "t  (dom (thr_α (thr s)))"
  and "wset_thread_ok (ws_α (wset s)) (thr_α (thr s))"
  shows "redT_upd (state_α s) t ta x' m' (state_α (exec_upd σ s t ta x' m'))"
  and "state_invar (exec_upd σ s t ta x' m')"
using assms unfolding wset_thread_ok_conv_dom
by(auto simp add: thr.update_correct thr.lookup_correct intro: exec_updWs_correct)

lemma execT_None:
  assumes invar: "state_invar s" "σ_invar σ (dom (thr_α (thr s)))" "state_α s  invariant"
  and exec: "execT σ s = None"
  shows "α.active_threads (state_α s) = {}"
using assms
by(cases "schedule σ s")(fastforce simp add: execT_def thr.lookup_correct dest: schedule_Some_NoneD schedule_NoneD)+

lemma execT_Some:
  assumes invar: "state_invar s" "σ_invar σ (dom (thr_α (thr s)))" "state_α s  invariant"
  and wstok: "wset_thread_ok (ws_α (wset s)) (thr_α (thr s))"
  and exec: "execT σ s = (σ', t, ta, s')"
  shows "α.redT (state_α s) (t, ta) (state_α s')" (is "?thesis1")
  and "state_invar s'" (is "?thesis2")
  and "σ_invar σ' (dom (thr_α (thr s')))" (is "?thesis3")
proof -
  note [simp del] = redT_upd_simps exec_upd_def

  have "?thesis1  ?thesis2  ?thesis3"
  proof(cases "fst (snd (the (schedule σ s)))")
    case None
    with exec invar have schedule: "schedule σ s = (t, None, σ')"
      and ta: "ta = (K$ [], [], [], [], [], convert_RA (snd (the (thr_α (thr s) t))))"
      and s': "s' = (acquire_all (locks s) t (snd (the (thr_α (thr s) t))), (thr_update t (fst (the (thr_α (thr s) t)), no_wait_locks) (thr s), shr s), wset s, interrupts s)"
      by(auto simp add: execT_def Option_bind_eq_Some_conv thr.lookup_correct split_beta split del: option.split_asm)
    from schedule_Some_NoneD[OF schedule invar]

    obtain x ln n where t: "thr_α (thr s) t = (x, ln)"
      and "0 < ln $ n" "¬ waiting (ws_α (wset s) t)" "may_acquire_all (locks s) t ln" by blast
    hence ?thesis1 using ta s' invar by(auto intro: α.redT.redT_acquire simp add: thr.update_correct)
    moreover from invar s' have "?thesis2" by(simp add: thr.update_correct)
    moreover from t s' invar have "dom (thr_α (thr s')) = dom (thr_α (thr s))" by(auto simp add: thr.update_correct)
    hence "?thesis3" using invar schedule by(auto intro: schedule_invar_None)
    ultimately show ?thesis by simp
  next
    case (Some taxm)
    with exec invar obtain x' m' 
      where schedule: "schedule σ s = (t, (ta, x', m'), σ')"
      and s': "s' = exec_upd σ s t ta x' m'"
      by(cases taxm)(fastforce simp add: execT_def Option_bind_eq_Some_conv split del: option.split_asm)
    from schedule_Some_SomeD[OF schedule invar]
    obtain x where t: "thr_α (thr s) t = (x, no_wait_locks)" 
      and "Predicate.eval (r t (x, shr s)) (ta, x', m')" 
      and aok: "α.actions_ok (state_α s) t ta" by blast
    with s' have ?thesis1 using invar wstok
      by(fastforce intro: α.redT.intros exec_upd_correct)
    moreover from invar s' t wstok have ?thesis2 by(auto intro: exec_upd_correct)
    moreover {
      from schedule invar
      have "σ_invar σ' (dom (thr_α (thr s))  {t. x m. NewThread t x m  set tat})"
        by(rule schedule_invar_Some)
      also have "dom (thr_α (thr s))  {t. x m. NewThread t x m  set tat} = dom (thr_α (thr s'))"
        using invar s' aok t
        by(auto simp add: exec_upd_def thr.lookup_correct thr.update_correct simp del: split_paired_Ex)(fastforce dest: redT_updTs_new_thread intro: redT_updTs_Some1 redT_updTs_new_thread_ts simp del: split_paired_Ex)+
      finally have "σ_invar σ' (dom (thr_α (thr s')))" . }
    ultimately show ?thesis by simp
  qed
  thus ?thesis1 ?thesis2 ?thesis3 by simp_all
qed

lemma exec_step_into_redT:
  assumes invar: "state_invar s" "σ_invar σ (dom (thr_α (thr s)))" "state_α s  invariant"
  and wstok: "wset_thread_ok (ws_α (wset s)) (thr_α (thr s))"
  and exec: "exec_step (σ, s) = Inl ((σ'', t, ta), σ', s')"
  shows "α.redT (state_α s) (t, ta) (state_α s')" "σ'' = σ"
  and "state_invar s'" "σ_invar σ' (dom (thr_α (thr s')))" "state_α s'  invariant"
proof -
  from exec have execT: "execT σ s = (σ', t, ta, s')" 
    and q: "σ'' = σ" by(auto simp add: exec_step.simps split_beta)
  from invar wstok execT show red: "α.redT (state_α s) (t, ta) (state_α s')" 
    and invar': "state_invar s'" "σ_invar σ' (dom (thr_α (thr s')))" "σ'' = σ"
    by(rule execT_Some)+(rule q)
  from invariant red ‹state_α s  invariant 
  show "state_α s'  invariant" by(rule invariant3pD)
qed

lemma exec_step_InrD:
  assumes "state_invar s" "σ_invar σ (dom (thr_α (thr s)))" "state_α s  invariant"
  and "exec_step (σ, s) = Inr s'"
  shows "α.active_threads (state_α s) = {}"
  and "s' = s"
using assms
by(auto simp add: exec_step_def dest: execT_None)

lemma (in multithreaded_base) red_in_active_threads:
  assumes "s -tta s'"
  shows "t  active_threads s"
using assms
by cases(auto intro: active_threads.intros)

lemma exec_aux_into_Runs:
  assumes "state_invar s" "σ_invar σ (dom (thr_α (thr s)))" "state_α s  invariant"
  and "wset_thread_ok (ws_α (wset s)) (thr_α (thr s))"
  shows "α.mthr.Runs (state_α s) (lmap snd (llist_of_tllist (exec_aux (σ, s))))" (is ?thesis1)
  and "tfinite (exec_aux (σ, s))  state_invar (terminal (exec_aux (σ, s)))" (is "_  ?thesis2")
proof -
  from assms show ?thesis1
  proof(coinduction arbitrary: σ s) 
    case (Runs σ s)
    note invar = ‹state_invar s σ_invar σ (dom (thr_α (thr s))) ‹state_α s  invariant
      and wstok = ‹wset_thread_ok (ws_α (wset s)) (thr_α (thr s))
    show ?case
    proof(cases "exec_aux (σ, s)")
      case (TNil s')
      hence "α.active_threads (state_α s) = {}" "s' = s"
        by(auto simp add: exec_aux_def unfold_tllist' split: sum.split_asm dest: exec_step_InrD[OF invar])
      hence ?Stuck using TNil by(auto dest: α.red_in_active_threads)
      thus ?thesis ..
    next
      case (TCons σtta ttls')
      then obtain t ta σ' s' σ''
        where [simp]: "σtta = (σ'', t, ta)"
        and [simp]: "ttls' = exec_aux (σ', s')"
        and step: "exec_step (σ, s) = Inl ((σ'', t, ta), σ', s')"
        unfolding exec_aux_def by(subst (asm) (2) unfold_tllist')(fastforce split: sum.split_asm)
      from invar wstok step
      have redT: "α.redT (state_α s) (t, ta) (state_α s')"
        and [simp]: "σ'' = σ"
        and invar': "state_invar s'" "σ_invar σ' (dom (thr_α (thr s')))" "state_α s'  invariant"
        by(rule exec_step_into_redT)+
      from wstok α.redT_preserves_wset_thread_ok[OF redT]
      have "wset_thread_ok (ws_α (wset s')) (thr_α (thr s'))" by simp
      with invar' redT TCons have ?Step by(auto simp del: split_paired_Ex)
      thus ?thesis ..
    qed
  qed
next
  assume "tfinite (exec_aux (σ, s))"
  thus "?thesis2" using assms
  proof(induct "exec_aux (σ, s)" arbitrary: σ s rule: tfinite_induct)
    case TNil thus ?case
      by(auto simp add: exec_aux_def unfold_tllist' split_beta split: sum.split_asm dest: exec_step_InrD)
  next
    case (TCons σtta ttls)
    from ‹TCons σtta ttls = exec_aux (σ, s)
    obtain σ'' t ta σ' s' 
      where [simp]: "σtta = (σ'', t, ta)"
      and ttls: "ttls = exec_aux (σ', s')"
      and step: "exec_step (σ, s) = Inl ((σ'', t, ta), σ', s')"
      unfolding exec_aux_def by(subst (asm) (2) unfold_tllist')(fastforce split: sum.split_asm)
    note ttls moreover
    from ‹state_invar s σ_invar σ (dom (thr_α (thr s))) ‹state_α s  invariant ‹wset_thread_ok (ws_α (wset s)) (thr_α (thr s)) step
    have [simp]: "σ'' = σ"
      and invar': "state_invar s'" "σ_invar σ' (dom (thr_α (thr s')))" "state_α s'  invariant"
      and redT: "α.redT (state_α s) (t, ta) (state_α s')"
      by(rule exec_step_into_redT)+
    note invar' moreover
    from α.redT_preserves_wset_thread_ok[OF redT] ‹wset_thread_ok (ws_α (wset s)) (thr_α (thr s))
    have "wset_thread_ok (ws_α (wset s')) (thr_α (thr s'))" by simp
    ultimately have "state_invar (terminal (exec_aux (σ', s')))" by(rule TCons)
    with ‹TCons σtta ttls = exec_aux (σ, s)[symmetric]
    show ?case unfolding ttls by simp
  qed
qed

end

locale scheduler_ext_aux =
  scheduler_ext_base
    final r convert_RA
    thr_α thr_invar thr_lookup thr_update thr_iterate
    ws_α ws_invar ws_lookup ws_update ws_sel
    is_α is_invar is_memb is_ins is_delete
    thr'_α thr'_invar thr'_empty thr'_ins_dj
  +
  scheduler_aux
    final r convert_RA
    thr_α thr_invar thr_lookup thr_update
    ws_α ws_invar ws_lookup
    is_α is_invar is_memb is_ins is_delete
  +
  thr: map_iteratei thr_α thr_invar thr_iterate +
  ws: map_update ws_α ws_invar ws_update +
  ws: map_sel' ws_α ws_invar ws_sel +
  thr': finite_set thr'_α thr'_invar +
  thr': set_empty thr'_α thr'_invar thr'_empty +
  thr': set_ins_dj thr'_α thr'_invar thr'_ins_dj  
  for final :: "'x  bool"
  and r :: "'t  ('x × 'm)  (('l,'t,'x,'m,'w,'o) thread_action × 'x × 'm) Predicate.pred"
  and convert_RA :: "'l released_locks  'o list"
  and thr_α :: "'m_t  ('l,'t,'x) thread_info"
  and thr_invar :: "'m_t  bool"
  and thr_lookup :: "'t  'm_t  ('x × 'l released_locks)"
  and thr_update :: "'t  'x × 'l released_locks  'm_t  'm_t"
  and thr_iterate :: "'m_t  ('t × ('x × 'l released_locks), 's_t) set_iterator"
  and ws_α :: "'m_w  ('w,'t) wait_sets"
  and ws_invar :: "'m_w  bool"
  and ws_lookup :: "'t  'm_w  'w wait_set_status"
  and ws_update :: "'t  'w wait_set_status  'm_w  'm_w"
  and ws_sel :: "'m_w  (('t × 'w wait_set_status)  bool)  ('t × 'w wait_set_status)"
  and is_α :: "'s_i  't interrupts"
  and is_invar :: "'s_i  bool"
  and is_memb :: "'t  's_i  bool"
  and is_ins :: "'t  's_i  's_i"
  and is_delete :: "'t  's_i  's_i"
  and thr'_α :: "'s_t  't set"
  and thr'_invar :: "'s_t  bool"
  and thr'_empty :: "unit  's_t"
  and thr'_ins_dj :: "'t  's_t  's_t"
begin

lemma active_threads_correct [simp]:
  assumes "state_invar s"
  shows "thr'_α (active_threads s) = α.active_threads (state_α s)" (is "?thesis1")
  and "thr'_invar (active_threads s)" (is "?thesis2")
proof -
  obtain ls ts m ws "is" where s: "s = (ls, (ts, m), ws, is)" by(cases s) fastforce
  let ?f = "λ(t, (x, ln)) TS. if ln = no_wait_locks
           then if Predicate.holds (do { (ta, _)  r t (x, m); Predicate.if_pred (actions_ok (ls, (ts, m), ws, is) t ta) })
                then thr'_ins_dj t TS else TS
           else if ¬ waiting (ws_lookup t ws)  may_acquire_all ls t ln then thr'_ins_dj t TS else TS"
  let ?I = "λT TS. thr'_invar TS  thr'_α TS  dom (thr_α ts) - T  (t. t  T  t  thr'_α TS  t  α.active_threads (state_α s))"

  from assms s have "thr_invar ts" by simp
  moreover have "?I (dom (thr_α ts)) (thr'_empty ())"
    by(auto simp add: thr'.empty_correct s elim: α.active_threads.cases)
  ultimately have "?I {} (thr_iterate ts (λ_. True) ?f (thr'_empty ()))"
  proof(rule thr.iterate_rule_P[where I="?I"])
    fix t xln T TS
    assume tT: "t  T" 
      and tst: "thr_α ts t = xln"
      and Tdom: "T  dom (thr_α ts)"
      and I: "?I T TS"
    obtain x ln where xln: "xln = (x, ln)" by(cases xln)
    from tT I have t: "t  thr'_α TS" by blast

    from I have invar: "thr'_invar TS" ..
    hence "thr'_invar (?f (t, xln) TS)" using t
      unfolding xln by(auto simp add: thr'.ins_dj_correct)
    moreover from I have "thr'_α TS  dom (thr_α ts) - T" by blast
    hence "thr'_α (?f (t, xln) TS)  dom (thr_α ts) - (T - {t})"
      using invar tst t by(auto simp add: xln thr'.ins_dj_correct)
    moreover
    {
      fix t'
      assume t': "t'  T - {t}"
      have "t'  thr'_α (?f (t, xln) TS)  t'  α.active_threads (state_α s)" (is "?lhs  ?rhs")
      proof(cases "t' = t")
        case True
        show ?thesis
        proof
          assume ?lhs
          with True xln invar tst ‹state_invar s t show ?rhs
            by(fastforce simp add: holds_eq thr'.ins_dj_correct s split_beta ws.lookup_correct split: if_split_asm elim!: bindE if_predE intro: α.active_threads.intros)
        next
          assume ?rhs
          with True xln invar tst ‹state_invar s t show ?lhs
            by(fastforce elim!: α.active_threads.cases simp add: holds_eq s thr'.ins_dj_correct ws.lookup_correct elim!: bindE if_predE intro: bindI if_predI)
        qed
      next
        case False
        with t' have "t'  T" by simp
        with I have "t'  thr'_α TS  t'  α.active_threads (state_α s)" by blast
        thus ?thesis using xln False invar t by(auto simp add: thr'.ins_dj_correct)
      qed
    }
    ultimately show "?I (T - {t}) (?f (t, xln) TS)" by blast
  qed
  thus "?thesis1" "?thesis2" by(auto simp add: s)
qed

end

locale scheduler_ext =
  scheduler_ext_aux
    final r convert_RA
    thr_α thr_invar thr_lookup thr_update thr_iterate
    ws_α ws_invar ws_lookup ws_update ws_sel
    is_α is_invar is_memb is_ins is_delete
    thr'_α thr'_invar thr'_empty thr'_ins_dj
  +
  scheduler_spec
    final r convert_RA
    schedule σ_invar
    thr_α thr_invar
    ws_α ws_invar
    is_α is_invar
    invariant
  +
  ws: map_delete ws_α ws_invar ws_delete +
  ws: map_iteratei ws_α ws_invar ws_iterate
  for final :: "'x  bool"
  and r :: "'t  ('x × 'm)  (('l,'t,'x,'m,'w,'o) thread_action × 'x × 'm) Predicate.pred"
  and convert_RA :: "'l released_locks  'o list"
  and schedule :: "('l,'t,'x,'m,'w,'o,'m_t,'m_w,'s_i,'s) scheduler"
  and "output" :: "'s  't  ('l,'t,'x,'m,'w,'o) thread_action  'q option"
  and σ_invar :: "'s  't set  bool"
  and thr_α :: "'m_t  ('l,'t,'x) thread_info"
  and thr_invar :: "'m_t  bool"
  and thr_lookup :: "'t  'm_t  ('x × 'l released_locks)"
  and thr_update :: "'t  'x × 'l released_locks  'm_t  'm_t"
  and thr_iterate :: "'m_t  ('t × ('x × 'l released_locks), 's_t) set_iterator"
  and ws_α :: "'m_w  ('w,'t) wait_sets"
  and ws_invar :: "'m_w  bool"
  and ws_empty :: "unit  'm_w"
  and ws_lookup :: "'t  'm_w  'w wait_set_status"
  and ws_update :: "'t  'w wait_set_status  'm_w  'm_w"
  and ws_delete :: "'t  'm_w  'm_w"
  and ws_iterate :: "'m_w  ('t × 'w wait_set_status, 'm_w) set_iterator"
  and ws_sel :: "'m_w  ('t × 'w wait_set_status  bool)  ('t × 'w wait_set_status)"
  and is_α :: "'s_i  't interrupts"
  and is_invar :: "'s_i  bool"
  and is_memb :: "'t  's_i  bool"
  and is_ins :: "'t  's_i  's_i"
  and is_delete :: "'t  's_i  's_i"
  and thr'_α :: "'s_t  't set"
  and thr'_invar :: "'s_t  bool"
  and thr'_empty :: "unit  's_t"
  and thr'_ins_dj :: "'t  's_t  's_t"
  and invariant :: "('l,'t,'x,'m,'w) state set"
  +
  assumes invariant: "invariant3p α.redT invariant"

sublocale scheduler_ext < 
  pick_wakeup_spec
    final r convert_RA
    pick_wakeup σ_invar
    thr_α thr_invar
    ws_α ws_invar
by(rule pick_wakeup_spec_via_sel)(unfold_locales)

sublocale scheduler_ext < 
  scheduler
    final r convert_RA
    schedule "output" "pick_wakeup" σ_invar
    thr_α thr_invar thr_lookup thr_update
    ws_α ws_invar ws_lookup ws_update ws_delete ws_iterate
    is_α is_invar is_memb is_ins is_delete
    invariant
by(unfold_locales)(rule invariant)

subsection ‹Schedulers for deterministic small-step semantics›

text ‹
  The default code equations for @{term Predicate.the} impose the type class constraint eq›
  on the predicate elements. For the semantics, which contains the heap, there might be no such
  instance, so we use new constants for which other code equations can be used.
  These do not add the type class constraint, but may fail more often with non-uniqueness exception.
›

definition singleton2 where [simp]: "singleton2 = Predicate.singleton"
definition the_only2 where [simp]: "the_only2 = Predicate.the_only"
definition the2 where [simp]: "the2 = Predicate.the"

context multithreaded_base begin

definition step_thread ::
  "(('l,'t,'x,'m,'w,'o) thread_action  's)  ('l,'t,'x,'m,'w) state  't
   ('t × (('l,'t,'x,'m,'w,'o) thread_action × 'x × 'm) option × 's) option"
where
  "ln. step_thread update_state s t =
   (case thr s t of
      (x, ln) 
      if ln = no_wait_locks then
        if ta x' m'. t  (x, shr s) -ta (x', m')  actions_ok s t ta then
          let
            (ta, x', m') = THE (ta, x', m'). t  (x, shr s) -ta (x', m')  actions_ok s t ta
          in
            (t, (ta, x', m'), update_state ta)
        else
          None
      else if may_acquire_all (locks s) t ln  ¬ waiting (wset s t) then 
        (t, None, update_state (K$ [], [], [], [], [], convert_RA ln))
      else
        None
    | None  None)"

lemma step_thread_NoneD:
  "step_thread update_state s t = None  t  active_threads s"
unfolding step_thread_def 
by(fastforce simp add: split_beta elim!: active_threads.cases split: if_split_asm)

lemma inactive_step_thread_eq_NoneI:
  "t  active_threads s  step_thread update_state s t = None"
unfolding step_thread_def
by(fastforce simp add: split_beta split: if_split_asm intro: active_threads.intros)

lemma step_thread_eq_None_conv:
  "step_thread update_state s t = None  t  active_threads s"
by(blast dest: step_thread_NoneD intro: inactive_step_thread_eq_NoneI)

lemma step_thread_eq_Some_activeD:
  "step_thread update_state s t = (t', taxmσ') 
   t' = t  t  active_threads s"
unfolding step_thread_def 
by(fastforce split: if_split_asm simp add: split_beta intro: active_threads.intros)

declare actions_ok_iff [simp del]
declare actions_ok.cases [rule del]

lemma step_thread_Some_NoneD:
  "step_thread update_state s t' = (t, None, σ')
   x ln n. thr s t = (x, ln)  ln $ n > 0  ¬ waiting (wset s t)  may_acquire_all (locks s) t ln  σ' = update_state (K$ [], [], [], [], [], convert_RA ln)"
unfolding step_thread_def
by(auto split: if_split_asm simp add: split_beta elim!: neq_no_wait_locksE)

lemma step_thread_Some_SomeD:
  " deterministic I; step_thread update_state s t' = (t, (ta, x', m'), σ'); s  I 
   x. thr s t = (x, no_wait_locks)  t  x, shr s -ta x', m'  actions_ok s t ta  σ' = update_state ta"
unfolding step_thread_def
by(auto simp add: split_beta deterministic_THE split: if_split_asm)

end

context scheduler_base_aux begin

definition step_thread ::
  "(('l,'t,'x,'m,'w,'o) thread_action  's)  ('l,'t,'m,'m_t,'m_w,'s_i) state_refine  't 
   ('t × (('l,'t,'x,'m,'w,'o) thread_action × 'x × 'm) option × 's) option"
where 
  "ln. step_thread update_state s t =
  (case thr_lookup t (thr s) of
      (x, ln) 
      if ln = no_wait_locks then
        let
          reds = do {
            (ta, x', m')  r t (x, shr s);
            if actions_ok s t ta then Predicate.single (ta, x', m') else bot
          }
        in
          if Predicate.holds (reds  (λ_. Predicate.single ())) then
            let
              (ta, x', m') = the2 reds
            in 
              (t, (ta, x', m'), update_state ta)
          else
            None
      else if may_acquire_all (locks s) t ln  ¬ waiting (ws_lookup t (wset s)) then 
        (t, None, update_state (K$ [], [], [], [], [],convert_RA ln))
      else
        None
    | None  None)"

end

context scheduler_aux begin

lemma deterministic_THE2:
  assumes "α.deterministic I"
  and tst: "thr_α (thr s) t = (x, no_wait_locks)"
  and red: "Predicate.eval (r t (x, shr s)) (ta, x', m')"
  and aok: "α.actions_ok (state_α s) t ta"
  and I: "state_α s  I"
  shows "Predicate.the (r t (x, shr s)  (λ(ta, x', m'). if α.actions_ok (state_α s) t ta then Predicate.single (ta, x', m') else bot)) = (ta, x', m')"
proof -
  show ?thesis unfolding the_def
    apply(rule the_equality)
     apply(rule bindI[OF red])
     apply(simp add: singleI aok)
    apply(erule bindE)
    apply(clarsimp split: if_split_asm)
     apply(drule (1) α.deterministicD[OF ‹α.deterministic I, where s="state_α s", simplified, OF red _ tst aok])
      apply(rule I)
     apply simp
    done
qed

lemma step_thread_correct:
  assumes det: "α.deterministic I"
  and invar: "σ_invar σ (dom (thr_α (thr s)))" "state_invar s" "state_α s  I"
  shows
  "map_option (apsnd (apsnd σ_α)) (step_thread update_state s t) = α.step_thread (σ_α  update_state) (state_α s) t" (is ?thesis1)
  and "(ta. FWThread.thread_oks (thr_α (thr s)) tat  σ_invar (update_state ta) (dom (thr_α (thr s))  {t. x m. NewThread t x m  set tat}))  case_option True (λ(t, taxm, σ). σ_invar σ (case taxm of None  dom (thr_α (thr s)) | Some (ta, x', m')  dom (thr_α (thr s))  {t. x m. NewThread t x m  set tat})) (step_thread update_state s t)"
  (is "(ta. ?tso ta  ?inv ta)  ?thesis2")
proof -
  have "?thesis1  ((ta. ?tso ta  ?inv ta)  ?thesis2)"
  proof(cases "step_thread update_state s t")
    case None
    with invar show ?thesis
      apply (auto simp add: thr.lookup_correct α.step_thread_def step_thread_def ws.lookup_correct
        split_beta holds_eq split: if_split_asm cong del: image_cong_simp)
       apply metis
      apply metis
      done
  next
    case (Some a)
    then obtain t' taxm σ' 
      where rrs: "step_thread update_state s t = (t', taxm, σ')" by(cases a) auto
    show ?thesis
    proof(cases "taxm")
      case None
      with rrs invar have ?thesis1
        by(auto simp add: thr.lookup_correct ws.lookup_correct α.step_thread_def step_thread_def split_beta split: if_split_asm)
      moreover {
        let ?ta = "(K$ [], [], [], [], [], convert_RA (snd (the (thr_lookup t (thr s)))))"
        assume "?tso ?ta  ?inv ?ta"
        hence ?thesis2 using None rrs
          by(auto simp add: thr.lookup_correct ws.lookup_correct α.step_thread_def step_thread_def split_beta split: if_split_asm) }
      ultimately show ?thesis by blast
    next
      case (Some a)
      with rrs obtain ta x' m'
        where rrs: "step_thread update_state s t =  (t', (ta, x', m'), σ')"
        by(cases a) fastforce
      with invar have ?thesis1 
        by (auto simp add: thr.lookup_correct ws.lookup_correct α.step_thread_def step_thread_def
          split_beta α.deterministic_THE [OF det, where s="state_α s", simplified]
          deterministic_THE2[OF det] holds_eq split: if_split_asm
          cong del: image_cong_simp) blast+
      moreover {
        assume "?tso ta  ?inv ta"
        hence ?thesis2 using rrs invar
          by(auto simp add: thr.lookup_correct ws.lookup_correct α.step_thread_def step_thread_def split_beta α.deterministic_THE[OF det, where s="state_α s", simplified] deterministic_THE2[OF det] holds_eq split: if_split_asm)(auto simp add: α.actions_ok_iff) 
      }
      ultimately show ?thesis by blast
    qed
  qed
  thus ?thesis1 "(ta. ?tso ta  ?inv ta)  ?thesis2" by blast+
qed

lemma step_thread_eq_None_conv:
  assumes det: "α.deterministic I"
  and invar: "state_invar s" "state_α s  I"
  shows "step_thread update_state s t = None  t  α.active_threads (state_α s)"
using assms step_thread_correct(1)[OF det _ invar(1), of "λ_ _. True", of id update_state t]
by(simp add: map_option.id α.step_thread_eq_None_conv)

lemma step_thread_Some_NoneD:
  assumes det: "α.deterministic I"
  and step: "step_thread update_state s t' = (t, None, σ')"
  and invar: "state_invar s" "state_α s  I"
  shows "x ln n. thr_α (thr s) t = (x, ln)  ln $ n > 0  ¬ waiting (ws_α (wset s) t)  may_acquire_all (locks s) t ln  σ' = update_state (K$ [], [], [], [], [], convert_RA ln)"
using assms step_thread_correct(1)[OF det _ invar(1), of "λ_ _. True", of id update_state t']
by(fastforce simp add: map_option.id dest: α.step_thread_Some_NoneD[OF sym])

lemma step_thread_Some_SomeD:
  assumes det: "α.deterministic I"
  and step: "step_thread update_state s t' = (t, (ta, x', m'), σ')"
  and invar: "state_invar s" "state_α s  I"
  shows "x. thr_α (thr s) t = (x, no_wait_locks)  Predicate.eval (r t (x, shr s)) (ta, x', m')  actions_ok s t ta  σ' = update_state ta"
using assms step_thread_correct(1)[OF det _ invar(1), of "λ_ _. True", of id update_state t']
by(auto simp add: map_option.id dest: α.step_thread_Some_SomeD[OF det sym])

end

subsection ‹Code Generator setup›

lemmas [code] =
  scheduler_base_aux.free_thread_id_def
  scheduler_base_aux.redT_updT.simps
  scheduler_base_aux.redT_updTs_def
  scheduler_base_aux.thread_ok.simps
  scheduler_base_aux.thread_oks.simps
  scheduler_base_aux.wset_actions_ok_def
  scheduler_base_aux.cond_action_ok.simps
  scheduler_base_aux.cond_action_oks_def
  scheduler_base_aux.redT_updI.simps
  scheduler_base_aux.redT_updIs.simps
  scheduler_base_aux.interrupt_action_ok.simps
  scheduler_base_aux.interrupt_actions_ok.simps
  scheduler_base_aux.actions_ok_def
  scheduler_base_aux.step_thread_def

lemmas [code] =
  scheduler_base.exec_updW.simps
  scheduler_base.exec_updWs_def
  scheduler_base.exec_upd_def
  scheduler_base.execT_def
  scheduler_base.exec_step.simps
  scheduler_base.exec_aux_def
  scheduler_base.exec_def

lemmas [code] =
  scheduler_ext_base.active_threads.simps

lemma singleton2_code [code]:
  "singleton2 dfault (Predicate.Seq f) =
  (case f () of
    Predicate.Empty  dfault ()
  | Predicate.Insert x P  
    if Predicate.is_empty P then x else Code.abort (STR ''singleton2 not unique'') (λ_. singleton2 dfault (Predicate.Seq f))
  | Predicate.Join P xq 
    if Predicate.is_empty P then 
      the_only2 dfault xq
    else if Predicate.null xq then singleton2 dfault P else Code.abort (STR ''singleton2 not unique'') (λ_. singleton2 dfault (Predicate.Seq f)))"
unfolding singleton2_def the_only2_def
by(auto simp only: singleton_code Code.abort_def split: seq.split if_split)

lemma the_only2_code [code]:
  "the_only2 dfault Predicate.Empty = Code.abort (STR ''the_only2 empty'') dfault"
  "the_only2 dfault (Predicate.Insert x P) = 
  (if Predicate.is_empty P then x else Code.abort (STR ''the_only2 not unique'') (λ_. the_only2 dfault (Predicate.Insert x P)))"
  "the_only2 dfault (Predicate.Join P xq) = 
  (if Predicate.is_empty P then 
     the_only2 dfault xq
   else if Predicate.null xq then 
     singleton2 dfault P 
   else
     Code.abort (STR ''the_only2 not unique'') (λ_. the_only2 dfault (Predicate.Join P xq)))"
unfolding singleton2_def the_only2_def by simp_all

lemma the2_eq [code]:
  "the2 A = singleton2 (λx. Code.abort (STR ''not_unique'') (λ_. the2 A)) A"
unfolding the2_def singleton2_def by(rule the_eq)

end

Theory Random_Scheduler

(*  Title:      JinjaThreads/Execute/Random_Scheduler.thy
    Author:     Andreas Lochbihler
*)

section ‹Random scheduler›

theory Random_Scheduler
imports
  Scheduler
begin

type_synonym random_scheduler = Random.seed

abbreviation (input)
  random_scheduler_invar :: "random_scheduler  't set  bool"
where "random_scheduler_invar  λ_ _. True"

locale random_scheduler_base =
  scheduler_ext_base
    final r convert_RA
    thr_α thr_invar thr_lookup thr_update thr_iterate
    ws_α ws_invar ws_lookup ws_update ws_sel
    is_α is_invar is_memb is_ins is_delete
    thr'_α thr'_invar thr'_empty thr'_ins_dj
  for final :: "'x  bool"
  and r :: "'t  ('x × 'm)  (('l,'t,'x,'m,'w,'o) thread_action × 'x × 'm) Predicate.pred"
  and convert_RA :: "'l released_locks  'o list"
  and "output" :: "random_scheduler  't  ('l,'t,'x,'m,'w,'o) thread_action  'q option"
  and thr_α :: "'m_t  ('l,'t,'x) thread_info"
  and thr_invar :: "'m_t  bool"
  and thr_lookup :: "'t  'm_t  ('x × 'l released_locks)"
  and thr_update :: "'t  'x × 'l released_locks  'm_t  'm_t"
  and thr_iterate :: "'m_t  ('t × ('x × 'l released_locks), 's_t) set_iterator"
  and ws_α :: "'m_w  ('w,'t) wait_sets"
  and ws_invar :: "'m_w  bool"
  and ws_lookup :: "'t  'm_w  'w wait_set_status"
  and ws_update :: "'t  'w wait_set_status  'm_w  'm_w"
  and ws_delete :: "'t  'm_w  'm_w"
  and ws_iterate :: "'m_w  ('t × 'w wait_set_status, 'm_w) set_iterator"
  and ws_sel :: "'m_w  ('t × 'w wait_set_status  bool)  ('t × 'w wait_set_status)"
  and is_α :: "'s_i  't interrupts"
  and is_invar :: "'s_i  bool"
  and is_memb :: "'t  's_i  bool"
  and is_ins :: "'t  's_i  's_i"
  and is_delete :: "'t  's_i  's_i"
  and thr'_α :: "'s_t  't set"
  and thr'_invar :: "'s_t  bool"
  and thr'_empty :: "unit  's_t"
  and thr'_ins_dj :: "'t  's_t  's_t"
  +
  fixes thr'_to_list :: "'s_t  't list"
begin

definition next_thread :: "random_scheduler  's_t  ('t × random_scheduler) option"
where
  "next_thread seed active = 
  (let ts = thr'_to_list active
   in if ts = [] then None else Some (Random.select (thr'_to_list active) seed))"

definition random_scheduler :: "('l,'t,'x,'m,'w,'o,'m_t,'m_w,'s_i,random_scheduler) scheduler"
where
  "random_scheduler seed s =
   (do {
      (t, seed')  next_thread seed (active_threads s);
      step_thread (λta. seed') s t
   })"

end

locale random_scheduler =
  random_scheduler_base
    final r convert_RA "output"
    thr_α thr_invar thr_lookup thr_update thr_iterate
    ws_α ws_invar ws_lookup ws_update ws_delete ws_iterate ws_sel
    is_α is_invar is_memb is_ins is_delete
    thr'_α thr'_invar thr'_empty thr'_ins_dj thr'_to_list
  +
  scheduler_ext_aux
    final r convert_RA
    thr_α thr_invar thr_lookup thr_update thr_iterate
    ws_α ws_invar ws_lookup ws_update ws_sel
    is_α is_invar is_memb is_ins is_delete
    thr'_α thr'_invar thr'_empty thr'_ins_dj
  +
  ws: map_delete ws_α ws_invar ws_delete +
  ws: map_iteratei ws_α ws_invar ws_iterate +
  thr': set_to_list thr'_α thr'_invar thr'_to_list 
  for final :: "'x  bool"
  and r :: "'t  ('x × 'm)  (('l,'t,'x,'m,'w,'o) thread_action × 'x × 'm) Predicate.pred"
  and convert_RA :: "'l released_locks  'o list"
  and "output" :: "random_scheduler  't  ('l,'t,'x,'m,'w,'o) thread_action  'q option"
  and thr_α :: "'m_t  ('l,'t,'x) thread_info"
  and thr_invar :: "'m_t  bool"
  and thr_lookup :: "'t  'm_t  ('x × 'l released_locks)"
  and thr_update :: "'t  'x × 'l released_locks  'm_t  'm_t"
  and thr_iterate :: "'m_t  ('t × ('x × 'l released_locks), 's_t) set_iterator"
  and ws_α :: "'m_w  ('w,'t) wait_sets"
  and ws_invar :: "'m_w  bool"
  and ws_lookup :: "'t  'm_w  'w wait_set_status"
  and ws_update :: "'t  'w wait_set_status  'm_w  'm_w"
  and ws_delete :: "'t  'm_w  'm_w"
  and ws_iterate :: "'m_w  ('t × 'w wait_set_status, 'm_w) set_iterator"
  and ws_sel :: "'m_w  ('t × 'w wait_set_status  bool)  ('t × 'w wait_set_status)"
  and is_α :: "'s_i  't interrupts"
  and is_invar :: "'s_i  bool"
  and is_memb :: "'t  's_i  bool"
  and is_ins :: "'t  's_i  's_i"
  and is_delete :: "'t  's_i  's_i"
  and thr'_α :: "'s_t  't set"
  and thr'_invar :: "'s_t  bool"
  and thr'_empty :: "unit  's_t"
  and thr'_ins_dj :: "'t  's_t  's_t"
  and thr'_to_list :: "'s_t  't list"
begin

lemma next_thread_eq_None_iff:
  assumes "thr'_invar active" "random_scheduler_invar seed T"
  shows "next_thread seed active = None  thr'_α active = {}"
using thr'.to_list_correct[OF assms(1)]
by(auto simp add: next_thread_def neq_Nil_conv)

lemma next_thread_eq_SomeD:
  assumes "next_thread seed active = Some (t, seed')"
  and "thr'_invar active" "random_scheduler_invar seed T"
  shows "t  thr'_α active"
using assms
by(auto simp add: next_thread_def thr'.to_list_correct split: if_split_asm dest: select[of _ seed])

lemma random_scheduler_spec:
  assumes det: "α.deterministic I"
  shows "scheduler_spec final r random_scheduler random_scheduler_invar thr_α thr_invar ws_α ws_invar is_α is_invar I"
proof
  fix σ s
  assume rr: "random_scheduler σ s = None"
    and invar: "random_scheduler_invar σ (dom (thr_α (thr s)))" "state_invar s" "state_α s  I"
  from invar(2) have "thr'_invar (active_threads s)" by(rule active_threads_correct)
  thus "α.active_threads (state_α s) = {}" using rr invar
    by(auto simp add: random_scheduler_def Option_bind_eq_None_conv next_thread_eq_None_iff step_thread_eq_None_conv[OF det] dest: next_thread_eq_SomeD)
next
  fix σ s t σ'
  assume rr: "random_scheduler σ s = (t, None, σ')"
    and invar: "random_scheduler_invar σ (dom (thr_α (thr s)))" "state_invar s" "state_α s  I"
  thus "x ln n. thr_α (thr s) t = (x, ln)  0 < ln $ n  ¬ waiting (ws_α (wset s) t)  may_acquire_all (locks s) t ln"
    by(fastforce simp add: random_scheduler_def Option_bind_eq_Some_conv dest: step_thread_Some_NoneD[OF det])
next
  fix σ s t ta x' m' σ'
  assume rr: "random_scheduler σ s = (t, (ta, x', m'), σ')"
    and invar: "random_scheduler_invar σ (dom (thr_α (thr s)))" "state_invar s" "state_α s  I"
  thus "x. thr_α (thr s) t = (x, no_wait_locks)  Predicate.eval (r t (x, shr s)) (ta, x', m')  α.actions_ok (state_α s) t ta"
    by(auto simp add: random_scheduler_def Option_bind_eq_Some_conv dest: step_thread_Some_SomeD[OF det])
qed simp_all

end

sublocale random_scheduler_base <
  scheduler_base
    final r convert_RA
    "random_scheduler" "output" "pick_wakeup_via_sel (λs P. ws_sel s (λ(k,v). P k v))" random_scheduler_invar
    thr_α thr_invar thr_lookup thr_update
    ws_α ws_invar ws_lookup ws_update ws_delete ws_iterate
    is_α is_invar is_memb is_ins is_delete
  for n0 .

sublocale random_scheduler <
  pick_wakeup_spec
    final r convert_RA
    "pick_wakeup_via_sel (λs P. ws_sel s (λ(k,v). P k v))" random_scheduler_invar
    thr_α thr_invar
    ws_α ws_invar
    is_α is_invar
by(rule pick_wakeup_spec_via_sel)(unfold_locales)

context random_scheduler begin

lemma random_scheduler_scheduler:
  assumes det: "α.deterministic I"
  shows 
  "scheduler
     final r convert_RA
     random_scheduler (pick_wakeup_via_sel (λs P. ws_sel s (λ(k,v). P k v))) random_scheduler_invar
     thr_α thr_invar thr_lookup thr_update 
     ws_α ws_invar ws_lookup ws_update ws_delete ws_iterate
     is_α is_invar is_memb is_ins is_delete
     I"
proof -
  interpret scheduler_spec
      final r convert_RA
      random_scheduler random_scheduler_invar
      thr_α thr_invar
      ws_α ws_invar
      is_α is_invar
      I
    using det by(rule random_scheduler_spec)

  show ?thesis by(unfold_locales)(rule α.deterministic_invariant3p[OF det])
qed

end

subsection ‹Code generator setup›

lemmas [code] =
  random_scheduler_base.next_thread_def
  random_scheduler_base.random_scheduler_def

end

Theory Round_Robin

(*  Title:      JinjaThreads/Execute/Round_Robin.thy
    Author:     Andreas Lochbihler
*)

section ‹Round robin scheduler›

theory Round_Robin
imports
  Scheduler
begin

text ‹
  A concrete scheduler must pick one possible reduction step from the small-step semantics for invidivual threads.
  Currently, this is only possible if there is only one such by using @{term Predicate.the}.
›

subsection ‹Concrete schedulers›

subsection ‹Round-robin schedulers›

type_synonym 'queue round_robin = "'queue × nat"
  ― ‹Waiting queue of threads and remaining number of steps of the first thread until it has to return resources›

primrec enqueue_new_thread :: "'t list  ('t,'x,'m) new_thread_action  't list"
where 
  "enqueue_new_thread queue (NewThread t x m) = queue @ [t]"
| "enqueue_new_thread queue (ThreadExists t b) = queue"

definition enqueue_new_threads :: "'t list  ('t,'x,'m) new_thread_action list  't list"
where
  "enqueue_new_threads = foldl enqueue_new_thread"

primrec round_robin_update_state :: "nat  't list round_robin  't  ('l,'t,'x,'m,'w,'o) thread_action  't list round_robin"
where 
  "round_robin_update_state n0 (queue, n) t ta =
   (let queue' = enqueue_new_threads queue tat
    in if n = 0  Yield  set tac then (rotate1 queue', n0) else (queue', n - 1))"

context multithreaded_base begin

abbreviation round_robin_step :: "nat  't list round_robin  ('l,'t,'x,'m,'w) state  't  ('t × (('l,'t,'x,'m,'w,'o) thread_action × 'x × 'm) option × 't list round_robin) option"
where
  "round_robin_step n0 σ s t  step_thread (round_robin_update_state n0 σ t) s t"

partial_function (option) round_robin_reschedule :: "'t  
    't list  nat  ('l,'t,'x,'m,'w) state  ('t × (('l,'t,'x,'m,'w,'o) thread_action × 'x × 'm) option × 't list round_robin) option"
where
  "round_robin_reschedule t0 queue n0 s =
   (let
      t = hd queue;
      queue' = tl queue
    in
      if t = t0 then
        None
      else
        case round_robin_step n0 (t # queue', n0) s t of
          None  round_robin_reschedule t0 (queue' @ [t]) n0 s
        | ttaxmσ  ttaxmσ)"

fun round_robin :: "nat  't list round_robin  ('l,'t,'x,'m,'w) state  ('t × (('l,'t,'x,'m,'w,'o) thread_action × 'x × 'm) option × 't list round_robin) option"
where 
  "round_robin n0 ([], n) s = None"
| "round_robin n0 (t # queue, n) s =
   (case round_robin_step n0 (t # queue, n) s t of
      ttaxmσ  ttaxmσ
    | None  round_robin_reschedule t (queue @ [t]) n0 s)"

end

primrec round_robin_invar :: "'t list round_robin  't set  bool"
where "round_robin_invar (queue, n) T  set queue = T  distinct queue"

lemma set_enqueue_new_thread: 
  "set (enqueue_new_thread queue nta) = set queue  {t. x m. nta = NewThread t x m}"
by(cases nta) auto

lemma set_enqueue_new_threads: 
  "set (enqueue_new_threads queue ntas) = set queue  {t. x m. NewThread t x m  set ntas}"
apply(induct ntas arbitrary: queue)
apply(auto simp add: enqueue_new_threads_def set_enqueue_new_thread)
done

lemma enqueue_new_thread_eq_Nil [simp]:
  "enqueue_new_thread queue nta = []  queue = []  (t b. nta = ThreadExists t b)"
by(cases nta) simp_all

lemma enqueue_new_threads_eq_Nil [simp]:
  "enqueue_new_threads queue ntas = []  queue = []  set ntas  {ThreadExists t b|t b. True}"
apply(induct ntas arbitrary: queue)
apply(auto simp add: enqueue_new_threads_def)
done

lemma distinct_enqueue_new_threads:
  fixes ts :: "('l,'t,'x) thread_info"
  and ntas :: "('t,'x,'m) new_thread_action list"
  assumes "thread_oks ts ntas" "set queue = dom ts" "distinct queue"
  shows "distinct (enqueue_new_threads queue ntas)"
using assms
proof(induct ntas arbitrary: ts queue)
  case Nil thus ?case by(simp add: enqueue_new_threads_def)
next
  case (Cons nt ntas)
  from ‹thread_oks ts (nt # ntas)
  have "thread_ok ts nt" and "thread_oks (redT_updT ts nt) ntas" by simp_all
  from ‹thread_ok ts nt ‹set queue = dom ts ‹distinct queue
  have "set (enqueue_new_thread queue nt) = dom (redT_updT ts nt)  distinct (enqueue_new_thread queue nt)"
    by(cases nt)(auto)
  with ‹thread_oks (redT_updT ts nt) ntas
  have "distinct (enqueue_new_threads (enqueue_new_thread queue nt) ntas)"
    by(blast intro: Cons.hyps)
  thus ?case by(simp add: enqueue_new_threads_def)
qed

lemma round_robin_reschedule_induct [consumes 1, case_names head rotate]:
  assumes major: "t0  set queue"
  and head: "queue. P (t0 # queue)"
  and rotate: "queue t.  t  t0; t0  set queue; P (queue @ [t])   P (t # queue)"
  shows "P queue"
using major
proof(induct n"length (takeWhile (λx. xt0) queue)" arbitrary: queue)
  case 0
  then obtain queue' where "queue = t0 # queue'"
    by(cases queue)(auto split: if_split_asm)
  thus ?case by(simp add: head)
next
  case (Suc n)
  then obtain t queue' where [simp]: "queue = t # queue'"
    and t: "t  t0" and n: "n = length (takeWhile (λx. x  t0) queue')"
    and t0: "t0  set queue'"
    by(cases queue)(auto split: if_split_asm)
  from n t0 have "n = length (takeWhile (λx. x  t0) (queue' @ [t]))" by(simp)
  moreover from t0 have "t0  set (queue' @ [t])" by simp
  ultimately have "P (queue' @ [t])" by(rule Suc.hyps)
  with t t0 show ?case by(simp add: rotate)
qed

context multithreaded_base begin

declare actions_ok_iff [simp del]
declare actions_ok.cases [rule del]

lemma round_robin_step_invar_None:
  " round_robin_step n0 σ s t' = (t, None, σ'); round_robin_invar σ (dom (thr s)) 
   round_robin_invar σ' (dom (thr s))"
by(cases σ)(auto dest: step_thread_Some_NoneD simp add: set_enqueue_new_threads distinct_enqueue_new_threads)

lemma round_robin_step_invar_Some:
  " deterministic I; round_robin_step n0 σ s t' = (t, (ta, x', m'), σ'); round_robin_invar σ (dom (thr s)); s  I 
   round_robin_invar σ' (dom (thr s)  {t. x m. NewThread t x m  set tat})"
apply(cases σ)
apply clarsimp
apply(frule (1) step_thread_Some_SomeD)
apply(auto split: if_split_asm simp add: split_beta set_enqueue_new_threads deterministic_THE)
apply(auto simp add: actions_ok_iff distinct_enqueue_new_threads)
done

lemma round_robin_reschedule_Cons:
  "round_robin_reschedule t0 (t0 # queue) n0 s = None"
  "t  t0  round_robin_reschedule t0 (t # queue) n0 s =
   (case round_robin_step n0 (t # queue, n0) s t of
      None  round_robin_reschedule t0 (queue @ [t]) n0 s
    | Some ttaxmσ  Some ttaxmσ)"
by(simp_all add: round_robin_reschedule.simps)

lemma round_robin_reschedule_NoneD:
  assumes rrr: "round_robin_reschedule t0 queue n0 s = None"
  and t0: "t0  set queue"
  shows "set (takeWhile (λt'. t'  t0) queue)  active_threads s = {}"
using t0 rrr
proof(induct queue rule: round_robin_reschedule_induct)
  case (head queue)
  thus ?case by simp
next
  case (rotate queue t)
  from ‹round_robin_reschedule t0 (t # queue) n0 s = None› t  t0
  have "round_robin_step n0 (t # queue, n0) s t = None" 
    and "round_robin_reschedule t0 (queue @ [t]) n0 s = None"
    by(simp_all add: round_robin_reschedule_Cons)
  from this(1) have "t  active_threads s" by(rule step_thread_NoneD)
  moreover from ‹round_robin_reschedule t0 (queue @ [t]) n0 s = None› 
  have "set (takeWhile (λt'. t'  t0) (queue @ [t]))  active_threads s = {}"
    by(rule rotate.hyps)
  moreover have "takeWhile (λt'. t'  t0) (queue @ [t]) = takeWhile (λt'. t'  t0) queue"
    using t0  set queue by simp
  ultimately show ?case using t  t0 by simp
qed

lemma round_robin_reschedule_Some_NoneD:
  assumes rrr: "round_robin_reschedule t0 queue n0 s = (t, None, σ')"
  and t0: "t0  set queue"
  shows "x ln n. thr s t = (x, ln)  ln $ n > 0  ¬ waiting (wset s t)  may_acquire_all (locks s) t ln"
using t0 rrr
proof(induct queue rule: round_robin_reschedule_induct)
  case head thus ?case by(simp add: round_robin_reschedule_Cons)
next
  case (rotate queue t')
  show ?case
  proof(cases "round_robin_step n0 (t' # queue, n0) s t'")
    case None
    with ‹round_robin_reschedule t0 (t' # queue) n0 s = (t, None, σ') t'  t0
    have "round_robin_reschedule t0 (queue @ [t']) n0 s = (t, None, σ')"
      by(simp add: round_robin_reschedule_Cons)
    thus ?thesis by(rule rotate.hyps)
  next
    case (Some a)
    with ‹round_robin_reschedule t0 (t' # queue) n0 s = (t, None, σ') t'  t0
    have "round_robin_step n0 (t' # queue, n0) s t' = (t, None, σ')"
      by(simp add: round_robin_reschedule_Cons)
    thus ?thesis by(blast dest: step_thread_Some_NoneD)
  qed
qed

lemma round_robin_reschedule_Some_SomeD:
  assumes "deterministic I"
  and rrr: "round_robin_reschedule t0 queue n0 s = (t, (ta, x', m'), σ')"
  and t0: "t0  set queue"
  and I: "s  I"
  shows "x. thr s t = (x, no_wait_locks)  t  x, shr s -ta x', m'  actions_ok s t ta"
using t0 rrr
proof(induct queue rule: round_robin_reschedule_induct)
  case head thus ?case by(simp add: round_robin_reschedule_Cons)
next
  case (rotate queue t')
  show ?case
  proof(cases "round_robin_step n0 (t' # queue, n0) s t'")
    case None
    with ‹round_robin_reschedule t0 (t' # queue) n0 s = (t, (ta, x', m'), σ') t'  t0
    have "round_robin_reschedule t0 (queue @ [t']) n0 s = (t, (ta, x', m'), σ')"
      by(simp add: round_robin_reschedule_Cons)
    thus ?thesis by(rule rotate.hyps)
  next
    case (Some a)
    with ‹round_robin_reschedule t0 (t' # queue) n0 s = (t, (ta, x', m'), σ') t'  t0
    have "round_robin_step n0 (t' # queue, n0) s t' = (t, (ta, x', m'), σ')"
      by(simp add: round_robin_reschedule_Cons)
    thus ?thesis using I by(blast dest: step_thread_Some_SomeD[OF ‹deterministic I])
  qed
qed

lemma round_robin_reschedule_invar_None:
  assumes rrr: "round_robin_reschedule t0 queue n0 s = (t, None, σ')"
  and invar: "round_robin_invar (queue, n0) (dom (thr s))"
  and t0: "t0  set queue"
  shows "round_robin_invar σ' (dom (thr s))"
using t0 rrr invar
proof(induct queue rule: round_robin_reschedule_induct)
  case head thus ?case by(simp add: round_robin_reschedule_Cons)
next
  case (rotate queue t')
  show ?case
  proof(cases "round_robin_step n0 (t' # queue, n0) s t'")
    case None
    with ‹round_robin_reschedule t0 (t' # queue) n0 s = (t, None, σ') t'  t0
    have "round_robin_reschedule t0 (queue @ [t']) n0 s = (t, None, σ')"
      by(simp add: round_robin_reschedule_Cons)
    moreover from ‹round_robin_invar (t' # queue, n0) (dom (thr s))
    have "round_robin_invar (queue @ [t'], n0) (dom (thr s))" by simp
    ultimately show ?thesis by(rule rotate.hyps)
  next
    case (Some a)
    with ‹round_robin_reschedule t0 (t' # queue) n0 s = (t, None, σ') t'  t0
    have "round_robin_step n0 (t' # queue, n0) s t' = (t, None, σ')"
      by(simp add: round_robin_reschedule_Cons)
    thus ?thesis using ‹round_robin_invar (t' # queue, n0) (dom (thr s))
      by(rule round_robin_step_invar_None)
  qed
qed

lemma round_robin_reschedule_invar_Some:
  assumes "deterministic I"
  and rrr: "round_robin_reschedule t0 queue n0 s = (t, (ta, x', m'), σ')"
  and invar: "round_robin_invar (queue, n0) (dom (thr s))"
  and t0: "t0  set queue"
  and "s  I"
  shows "round_robin_invar σ' (dom (thr s)  {t. x m. NewThread t x m  set tat})"
using t0 rrr invar
proof(induct queue rule: round_robin_reschedule_induct)
  case head thus ?case by(simp add: round_robin_reschedule_Cons)
next
  case (rotate queue t')
  show ?case
  proof(cases "round_robin_step n0 (t' # queue, n0) s t'")
    case None
    with ‹round_robin_reschedule t0 (t' # queue) n0 s = (t, (ta, x', m'), σ') t'  t0
    have "round_robin_reschedule t0 (queue @ [t']) n0 s = (t, (ta, x', m'), σ')"
      by(simp add: round_robin_reschedule_Cons)
    moreover from ‹round_robin_invar (t' # queue, n0) (dom (thr s))
    have "round_robin_invar (queue @ [t'], n0) (dom (thr s))" by simp
    ultimately show ?thesis by(rule rotate.hyps)
  next
    case (Some a)
    with ‹round_robin_reschedule t0 (t' # queue) n0 s = (t, (ta, x', m'), σ') t'  t0
    have "round_robin_step n0 (t' # queue, n0) s t' = (t, (ta, x', m'), σ')"
      by(simp add: round_robin_reschedule_Cons)
    thus ?thesis using ‹round_robin_invar (t' # queue, n0) (dom (thr s)) s  I
      by(rule round_robin_step_invar_Some[OF ‹deterministic I])
  qed
qed

lemma round_robin_NoneD: 
  assumes rr: "round_robin n0 σ s = None"
  and invar: "round_robin_invar σ (dom (thr s))"
  shows "active_threads s = {}"
proof -
  obtain queue n where σ: "σ = (queue, n)" by(cases σ)
  show ?thesis
  proof(cases queue)
    case Nil
    thus ?thesis using invar σ by(fastforce elim: active_threads.cases)
  next
    case (Cons t queue')
    with rr σ have "round_robin_step n0 (t # queue', n) s t = None"
      and "round_robin_reschedule t (queue' @ [t]) n0 s = None" by simp_all
    from ‹round_robin_step n0 (t # queue', n) s t = None›
    have "t  active_threads s" by(rule step_thread_NoneD)
    moreover from ‹round_robin_reschedule t (queue' @ [t]) n0 s = None›
    have "set (takeWhile (λx. x  t) (queue' @ [t]))  active_threads s = {}"
      by(rule round_robin_reschedule_NoneD) simp
    moreover from invar σ Cons
    have "takeWhile (λx. x  t) (queue' @ [t]) = queue'"
      by(subst takeWhile_append2) auto
    moreover from invar have "active_threads s  set queue"
      using σ by(auto elim: active_threads.cases)
    ultimately show ?thesis using Cons by auto
  qed
qed

lemma round_robin_Some_NoneD:
  assumes rr: "round_robin n0 σ s = (t, None, σ')"
  shows "x ln n. thr s t = (x, ln)  ln $ n > 0  ¬ waiting (wset s t)  may_acquire_all (locks s) t ln"
proof -
  obtain queue n where σ: "σ = (queue, n)" by(cases σ)
  with rr have "queue  []" by clarsimp
  then obtain t' queue' where queue: "queue = t' # queue'"
    by(auto simp add: neq_Nil_conv)
  show ?thesis
  proof(cases "round_robin_step n0 (t' # queue', n) s t'")
    case (Some a)
    with rr queue σ have "round_robin_step n0 (t' # queue', n) s t' = (t, None, σ')" by simp
    thus ?thesis by(blast dest: step_thread_Some_NoneD)
  next
    case None
    with rr queue σ have "round_robin_reschedule t' (queue' @ [t']) n0 s = (t, None, σ')" by simp
    thus ?thesis by(rule round_robin_reschedule_Some_NoneD)simp
  qed
qed

lemma round_robin_Some_SomeD:
  assumes "deterministic I"
  and rr: "round_robin n0 σ s = (t, (ta, x', m'), σ')"
  and "s  I"
  shows "x. thr s t = (x, no_wait_locks)  t  x, shr s -ta x', m'  actions_ok s t ta"
proof -
  obtain queue n where σ: "σ = (queue, n)" by(cases σ)
  with rr have "queue  []" by clarsimp
  then obtain t' queue' where queue: "queue = t' # queue'"
    by(auto simp add: neq_Nil_conv)
  show ?thesis
  proof(cases "round_robin_step n0 (t' # queue', n) s t'")
    case (Some a)
    with rr queue σ have "round_robin_step n0 (t' # queue', n) s t' = (t, (ta, x', m'), σ')" by simp
    thus ?thesis using s  I by(blast dest: step_thread_Some_SomeD[OF ‹deterministic I])
  next
    case None
    with rr queue σ have "round_robin_reschedule t' (queue' @ [t']) n0 s = (t, (ta, x', m'), σ')" by simp
    thus ?thesis by(rule round_robin_reschedule_Some_SomeD[OF ‹deterministic I])(simp_all add: s  I)
  qed
qed

lemma round_robin_invar_None:
  assumes rr: "round_robin n0 σ s = (t, None, σ')"
  and invar: "round_robin_invar σ (dom (thr s))"
  shows "round_robin_invar σ' (dom (thr s))"
proof -
  obtain queue n where σ: "σ = (queue, n)" by(cases σ)
  with rr have "queue  []" by clarsimp
  then obtain t' queue' where queue: "queue = t' # queue'"
    by(auto simp add: neq_Nil_conv)
  show ?thesis
  proof(cases "round_robin_step n0 (t' # queue', n) s t'")
    case (Some a)
    with rr queue σ have "round_robin_step n0 (t' # queue', n) s t' = (t, None, σ')" by simp
    thus ?thesis using invar unfolding σ queue by(rule round_robin_step_invar_None)
  next
    case None
    with rr queue σ have "round_robin_reschedule t' (queue' @ [t']) n0 s = (t, None, σ')" by simp
    moreover from invar queue σ have "round_robin_invar (queue' @ [t'], n0) (dom (thr s))" by simp
    ultimately show ?thesis by(rule round_robin_reschedule_invar_None) simp
  qed
qed

lemma round_robin_invar_Some:
  assumes "deterministic I"
  and rr: "round_robin n0 σ s = (t, (ta, x', m'), σ')"
  and invar: "round_robin_invar σ (dom (thr s))" "s  I"
  shows "round_robin_invar σ' (dom (thr s)  {t. x m. NewThread t x m  set tat})"
proof -
  obtain queue n where σ: "σ = (queue, n)" by(cases σ)
  with rr have "queue  []" by clarsimp
  then obtain t' queue' where queue: "queue = t' # queue'"
    by(auto simp add: neq_Nil_conv)
  show ?thesis
  proof(cases "round_robin_step n0 (t' # queue', n) s t'")
    case (Some a)
    with rr queue σ have "round_robin_step n0 (t' # queue', n) s t' = (t, (ta, x', m'), σ')" by simp
    thus ?thesis using invar unfolding σ queue by(rule round_robin_step_invar_Some[OF ‹deterministic I])
  next
    case None
    with rr queue σ have "round_robin_reschedule t' (queue' @ [t']) n0 s = (t, (ta, x', m'), σ')" by simp
    moreover from invar queue σ
    have "round_robin_invar (queue' @ [t'], n0) (dom (thr s))" by simp
    ultimately show ?thesis by(rule round_robin_reschedule_invar_Some[OF ‹deterministic I])(simp_all add: s  I)
  qed
qed

end

locale round_robin_base =
  scheduler_base_aux
    final r convert_RA
    thr_α thr_invar thr_lookup thr_update
    ws_α ws_invar ws_lookup
    is_α is_invar is_memb is_ins is_delete
  for final :: "'x  bool"
  and r :: "'t  ('x × 'm)  (('l,'t,'x,'m,'w,'o) thread_action × 'x × 'm) Predicate.pred"
  and convert_RA :: "'l released_locks  'o list"
  and "output" :: "'queue round_robin  't  ('l,'t,'x,'m,'w,'o) thread_action  'q option"
  and thr_α :: "'m_t  ('l,'t,'x) thread_info"
  and thr_invar :: "'m_t  bool"
  and thr_lookup :: "'t  'm_t  ('x × 'l released_locks)"
  and thr_update :: "'t  'x × 'l released_locks  'm_t  'm_t"
  and ws_α :: "'m_w  ('w,'t) wait_sets"
  and ws_invar :: "'m_w  bool"
  and ws_lookup :: "'t  'm_w  'w wait_set_status"
  and ws_update :: "'t  'w wait_set_status  'm_w  'm_w"
  and ws_delete :: "'t  'm_w  'm_w"
  and ws_iterate :: "'m_w  ('t × 'w wait_set_status, 'm_w) set_iterator"
  and ws_sel :: "'m_w  ('t × 'w wait_set_status  bool)  ('t × 'w wait_set_status)"
  and is_α :: "'s_i  't interrupts"
  and is_invar :: "'s_i  bool"
  and is_memb :: "'t  's_i  bool"
  and is_ins :: "'t  's_i  's_i"
  and is_delete :: "'t  's_i  's_i"
  +
  fixes queue_α :: "'queue  't list"
  and queue_invar :: "'queue  bool"
  and queue_empty :: "unit  'queue"
  and queue_isEmpty :: "'queue  bool"
  and queue_enqueue :: "'t  'queue  'queue"
  and queue_dequeue :: "'queue  't × 'queue"
  and queue_push :: "'t  'queue  'queue"
begin

definition queue_rotate1 :: "'queue  'queue"
where "queue_rotate1 = case_prod queue_enqueue  queue_dequeue"

primrec enqueue_new_thread :: "'queue  ('t,'x,'m) new_thread_action  'queue"
where 
  "enqueue_new_thread ts (NewThread t x m) = queue_enqueue t ts"
| "enqueue_new_thread ts (ThreadExists t b) = ts"

definition enqueue_new_threads :: "'queue  ('t,'x,'m) new_thread_action list  'queue"
where
  "enqueue_new_threads = foldl enqueue_new_thread"

primrec round_robin_update_state :: "nat  'queue round_robin  't  ('l,'t,'x,'m,'w,'o) thread_action  'queue round_robin"
where 
  "round_robin_update_state n0 (queue, n) t ta =
   (let queue' = enqueue_new_threads queue tat
    in if n = 0  Yield  set tac then (queue_rotate1 queue', n0) else (queue', n - 1))"

abbreviation round_robin_step ::
  "nat  'queue round_robin  ('l,'t,'m,'m_t,'m_w,'s_i) state_refine  't 
   ('t × (('l,'t,'x,'m,'w,'o) thread_action × 'x × 'm) option × 'queue round_robin) option"
where
  "round_robin_step n0 σ s t  step_thread (round_robin_update_state n0 σ t) s t"

partial_function (option) round_robin_reschedule ::
  "'t  'queue  nat  ('l,'t,'m,'m_t,'m_w,'s_i) state_refine 
   ('t × (('l,'t,'x,'m,'w,'o) thread_action × 'x × 'm) option × 'queue round_robin) option"
where
  "round_robin_reschedule t0 queue n0 s =
   (let
      (t, queue') = queue_dequeue queue
    in
      if t = t0 then
        None 
      else
        case round_robin_step n0 (queue_push t queue', n0) s t of
          None  round_robin_reschedule t0 (queue_enqueue t queue') n0 s
        | ttaxmσ  ttaxmσ)"

primrec round_robin :: "nat  ('l,'t,'x,'m,'w,'o,'m_t,'m_w,'s_i,'queue round_robin) scheduler"
where 
  "round_robin n0 (queue, n) s = 
   (if queue_isEmpty queue then None
    else
      let
        (t, queue') = queue_dequeue queue
      in
        (case round_robin_step n0 (queue_push t queue', n) s t of
           ttaxmσ  ttaxmσ
         | None  round_robin_reschedule t (queue_enqueue t queue') n0 s))"

primrec round_robin_invar :: "'queue round_robin  't set  bool"
where "round_robin_invar (queue, n) T  queue_invar queue  Round_Robin.round_robin_invar (queue_α queue, n) T"

definition round_robin_α :: "'queue round_robin  't list round_robin"
where "round_robin_α = apfst queue_α"

definition round_robin_start :: "nat  't  'queue round_robin"
where "round_robin_start n0 t = (queue_enqueue t (queue_empty ()), n0)"

lemma round_robin_invar_correct:
  "round_robin_invar σ T  Round_Robin.round_robin_invar (round_robin_α σ) T"
by(cases σ)(simp add: round_robin_α_def)

end

locale round_robin =
  round_robin_base
    final r convert_RA "output"
    thr_α thr_invar thr_lookup thr_update
    ws_α ws_invar ws_lookup ws_update ws_delete ws_iterate ws_sel
    is_α is_invar is_memb is_ins is_delete
    queue_α queue_invar queue_empty queue_isEmpty queue_enqueue queue_dequeue queue_push
  +
  scheduler_aux
    final r convert_RA
    thr_α thr_invar thr_lookup thr_update
    ws_α ws_invar ws_lookup
    is_α is_invar is_memb is_ins is_delete
  +
  ws: map_update ws_α ws_invar ws_update +
  ws: map_delete ws_α ws_invar ws_delete +
  ws: map_iteratei ws_α ws_invar ws_iterate +
  ws: map_sel' ws_α ws_invar ws_sel +
  queue: list queue_α queue_invar +
  queue: list_empty queue_α queue_invar queue_empty +
  queue: list_isEmpty queue_α queue_invar queue_isEmpty +
  queue: list_enqueue queue_α queue_invar queue_enqueue +
  queue: list_dequeue queue_α queue_invar queue_dequeue +
  queue: list_push queue_α queue_invar queue_push
  for final :: "'x  bool"
  and r :: "'t  ('x × 'm)  (('l,'t,'x,'m,'w,'o) thread_action × 'x × 'm) Predicate.pred"
  and convert_RA :: "'l released_locks  'o list"
  and "output" :: "'queue round_robin  't  ('l,'t,'x,'m,'w,'o) thread_action  'q option"
  and thr_α :: "'m_t  ('l,'t,'x) thread_info"
  and thr_invar :: "'m_t  bool"
  and thr_lookup :: "'t  'm_t  ('x × 'l released_locks)"
  and thr_update :: "'t  'x × 'l released_locks  'm_t  'm_t"
  and ws_α :: "'m_w  ('w,'t) wait_sets"
  and ws_invar :: "'m_w  bool"
  and ws_lookup :: "'t  'm_w  'w wait_set_status"
  and ws_update :: "'t  'w wait_set_status  'm_w  'm_w"
  and ws_delete :: "'t  'm_w  'm_w"
  and ws_iterate :: "'m_w  ('t × 'w wait_set_status, 'm_w) set_iterator"
  and ws_sel :: "'m_w  ('t × 'w wait_set_status  bool)  ('t × 'w wait_set_status)"
  and is_α :: "'s_i  't interrupts"
  and is_invar :: "'s_i  bool"
  and is_memb :: "'t  's_i  bool"
  and is_ins :: "'t  's_i  's_i"
  and is_delete :: "'t  's_i  's_i"
  and queue_α :: "'queue  't list"
  and queue_invar :: "'queue  bool"
  and queue_empty :: "unit  'queue"
  and queue_isEmpty :: "'queue  bool"
  and queue_enqueue :: "'t  'queue  'queue"
  and queue_dequeue :: "'queue  't × 'queue"
  and queue_push :: "'t  'queue  'queue"
begin

lemma queue_rotate1_correct:
  assumes "queue_invar queue" "queue_α queue  []"
  shows "queue_α (queue_rotate1 queue) = rotate1 (queue_α queue)"
  and "queue_invar (queue_rotate1 queue)"
using assms
apply(auto simp add: queue_rotate1_def split_beta queue.dequeue_correct queue.enqueue_correct)
by(cases "queue_α queue") simp_all

lemma enqueue_thread_correct:
  assumes "queue_invar queue"
  shows "queue_α (enqueue_new_thread queue nta) = Round_Robin.enqueue_new_thread (queue_α queue) nta"
  and "queue_invar (enqueue_new_thread queue nta)"
using assms
by(case_tac [!] nta)(simp_all add: queue.enqueue_correct)

lemma enqueue_threads_correct:
  assumes "queue_invar queue"
  shows "queue_α (enqueue_new_threads queue ntas) = Round_Robin.enqueue_new_threads (queue_α queue) ntas"
  and "queue_invar (enqueue_new_threads queue ntas)"
using assms
apply(induct ntas arbitrary: queue)
apply(simp_all add: enqueue_new_threads_def Round_Robin.enqueue_new_threads_def enqueue_thread_correct)
done

lemma round_robin_update_thread_correct:
  assumes "round_robin_invar σ T" "t'  T"
  shows "round_robin_α (round_robin_update_state n0 σ t ta) = Round_Robin.round_robin_update_state n0 (round_robin_α σ) t ta"
using assms
apply(cases σ)
apply(auto simp add: round_robin_α_def queue_rotate1_correct enqueue_threads_correct del: conjI)
apply(subst (1 2) queue_rotate1_correct)
apply(auto simp add: enqueue_threads_correct)
done

lemma round_robin_step_correct:
  assumes det: "α.deterministic I"
  and invar: "round_robin_invar σ (dom (thr_α (thr s)))" "state_invar s" "state_α s  I"
  shows
  "map_option (apsnd (apsnd round_robin_α)) (round_robin_step n0 σ s t) = 
   α.round_robin_step n0 (round_robin_α σ) (state_α s) t" (is ?thesis1)
  and "case_option True (λ(t, taxm, σ). round_robin_invar σ (case taxm of None  dom (thr_α (thr s)) | Some (ta, x', m')  dom (thr_α (thr s))  {t. x m. NewThread t x m  set tat})) (round_robin_step n0 σ s t)"
  (is ?thesis2)
proof -
  have "?thesis1  ?thesis2"
  proof(cases "dom (thr_α (thr s)) = {}")
    case True
    thus ?thesis using invar
      apply(cases σ)
      apply(auto dest: step_thread_Some_NoneD[OF det] step_thread_Some_SomeD[OF det])
      apply(fastforce simp add: α.step_thread_eq_None_conv elim: α.active_threads.cases intro: sym)
      done
  next
    case False
    then obtain t' where t': "t'  dom (thr_α (thr s))" by blast
    hence ?thesis1
      using step_thread_correct(1)[of I round_robin_invar σ s round_robin_α "round_robin_update_state n0 σ t" t, OF det invar]
      unfolding o_def using invar
      by(subst (asm) round_robin_update_thread_correct) auto
    moreover
    { fix ta :: "('l, 't, 'x, 'm, 'w, 'o) thread_action"
      assume "FWThread.thread_oks (thr_α (thr s)) tat"
      moreover from t' invar have "queue_α (fst σ)  []" by(cases σ) auto
      ultimately have "round_robin_invar (round_robin_update_state n0 σ t ta) (dom (thr_α (thr s))  {t. x m. NewThread t x m  set tat})"
        using invar t' by(cases σ)(auto simp add: queue_rotate1_correct enqueue_threads_correct set_enqueue_new_threads iff del: domIff intro: distinct_enqueue_new_threads) }
    from step_thread_correct(2)[OF det, of round_robin_invar σ s "round_robin_update_state n0 σ t" t, OF invar this]
    have ?thesis2 using t' invar by simp
    ultimately show ?thesis by blast
  qed
  thus ?thesis1 ?thesis2 by blast+
qed

lemma round_robin_reschedule_correct:
  assumes det: "α.deterministic I"
  and invar: "round_robin_invar (queue, n) (dom (thr_α (thr s)))" "state_invar s" "state_α s  I"
  and t0: "t0  set (queue_α queue)"
  shows "map_option (apsnd (apsnd round_robin_α)) (round_robin_reschedule t0 queue n0 s) =
     α.round_robin_reschedule t0 (queue_α queue) n0 (state_α s)"
  and "case_option True (λ(t, taxm, σ). round_robin_invar σ (case taxm of None  dom (thr_α (thr s)) | Some (ta, x', m')  dom (thr_α (thr s))  {t. x m. NewThread t x m  set tat})) (round_robin_reschedule t0 queue n0 s)"
using t0 invar
proof(induct "queue_α queue" arbitrary: queue n rule: round_robin_reschedule_induct)
  case head
  { case 1 thus ?case using head[symmetric]
      by(subst round_robin_reschedule.simps)(subst α.round_robin_reschedule.simps, clarsimp simp add: split_beta queue.dequeue_correct) 
  next
    case 2 thus ?case using head[symmetric]
      by(subst round_robin_reschedule.simps)(clarsimp simp add: split_beta queue.dequeue_correct) }
next
  case (rotate αqueue' t)
  obtain t' queue' where queue': "queue_dequeue queue = (t', queue')" by(cases "queue_dequeue queue")
  note [simp] = t # αqueue' = queue_α queue[symmetric]
  { case 1
    with queue' have [simp]: "t' = t" "αqueue' = queue_α queue'" "queue_invar queue'" by(auto elim: queue.removelE)
    from 1 queue' have invar': "round_robin_invar (queue_push t queue', n0) (dom (thr_α (thr s)))"
      by(auto simp add: queue.push_correct)
    show ?case
    proof(cases "round_robin_step n0 (queue_push t queue', n0) s t")
      case Some thus ?thesis
        using queue' t  t0 round_robin_step_correct[OF det invar' ‹state_invar s, of n0 t] invar' ‹state_α s  I
        by(subst round_robin_reschedule.simps)(subst α.round_robin_reschedule.simps, auto simp add: round_robin_α_def queue.push_correct)
    next
      case None
      hence αNone: "α.round_robin_step n0 (queue_α (queue_push t queue'), n0) (state_α s) t = None"
        using round_robin_step_correct[OF det invar' ‹state_invar s, of n0 t] invar' ‹state_α s  I
        by(auto simp add: queue.push_correct round_robin_α_def)
      have "αqueue' @ [t] = queue_α (queue_enqueue t queue')" by(simp add: queue.enqueue_correct)
      moreover from invar'
      have "round_robin_invar (queue_enqueue t queue', n0) (dom (thr_α (thr s)))"
        by(auto simp add: queue.enqueue_correct queue.push_correct)
      ultimately 
      have "map_option (apsnd (apsnd round_robin_α)) (round_robin_reschedule t0 (queue_enqueue t queue') n0 s) =
            α.round_robin_reschedule t0 (queue_α (queue_enqueue t queue')) n0 (state_α s)"
        using ‹state_invar s ‹state_α s  I by(rule rotate.hyps)
      thus ?thesis using None αNone t  t0 invar' queue'
        by(subst round_robin_reschedule.simps)(subst α.round_robin_reschedule.simps, auto simp add: queue.enqueue_correct queue.push_correct)
    qed
  next
    case 2
    with queue' have [simp]: "t' = t" "αqueue' = queue_α queue'" "queue_invar queue'" by(auto elim: queue.removelE)
    from 2 queue' have invar': "round_robin_invar (queue_push t queue', n0) (dom (thr_α (thr s)))"
      by(auto simp add: queue.push_correct)
    show ?case
    proof(cases "round_robin_step n0 (queue_push t queue', n0) s t")
      case Some thus ?thesis
        using queue' t  t0 round_robin_step_correct[OF det invar' ‹state_invar s, of n0 t] invar' ‹state_α s  I
        by(subst round_robin_reschedule.simps)(auto simp add: round_robin_α_def queue.push_correct)
    next
      case None
      have "αqueue' @ [t] = queue_α (queue_enqueue t queue')" by(simp add: queue.enqueue_correct)
      moreover from invar'
      have "round_robin_invar (queue_enqueue t queue', n0) (dom (thr_α (thr s)))"
        by(auto simp add: queue.enqueue_correct queue.push_correct)
      ultimately 
      have "case_option True (λ(t, taxm, σ). round_robin_invar σ (case_option (dom (thr_α (thr s))) (λ(ta, x', m'). dom (thr_α (thr s))  {t. x m. NewThread t x m  set tat}) taxm)) (round_robin_reschedule t0 (queue_enqueue t queue') n0 s)"
        using ‹state_invar s ‹state_α s  I by(rule rotate.hyps)
      thus ?thesis using None t  t0 invar' queue'
        by(subst round_robin_reschedule.simps)(auto simp add: queue.enqueue_correct queue.push_correct)
    qed
  }
qed

lemma round_robin_correct:
  assumes det: "α.deterministic I"
  and invar: "round_robin_invar σ (dom (thr_α (thr s)))" "state_invar s" "state_α s  I"
  shows "map_option (apsnd (apsnd round_robin_α)) (round_robin n0 σ s) =
         α.round_robin n0 (round_robin_α σ) (state_α s)"
    (is ?thesis1)
  and "case_option True (λ(t, taxm, σ). round_robin_invar σ (case taxm of None  dom (thr_α (thr s)) | Some (ta, x', m')  dom (thr_α (thr s))  {t. x m. NewThread t x m  set tat})) (round_robin n0 σ s)"
    (is ?thesis2)
proof -
  obtain queue n where σ: "σ = (queue, n)" by(cases σ)
  have "?thesis1  ?thesis2"
  proof(cases "queue_α queue")
    case Nil thus ?thesis using invar σ
      by(auto simp add: split_beta queue.isEmpty_correct round_robin_α_def)
  next
    case (Cons t αqueue')
    with invar σ obtain queue'
      where [simp]: "queue_dequeue queue = (t, queue')" "αqueue' = queue_α queue'" "queue_invar queue'"
      by(auto elim: queue.removelE)
    from invar σ Cons have invar': "round_robin_invar (queue_push t queue', n) (dom (thr_α (thr s)))"
      by(auto simp add: queue.push_correct)
    from invar σ Cons have invar'': "round_robin_invar (queue_enqueue t queue', n0) (dom (thr_α (thr s)))"
      by(auto simp add: queue.enqueue_correct)
    show ?thesis
    proof(cases "round_robin_step n0 (queue_push t queue', n) s t")
      case Some
      with σ Cons invar show ?thesis
        using round_robin_step_correct[OF det invar' ‹state_invar s, of n0 t]
        by(auto simp add: queue.isEmpty_correct queue.push_correct round_robin_α_def)
    next
      case None
      from invar σ Cons have "t  set (queue_α (queue_enqueue t queue'))"
        by(auto simp add: queue.enqueue_correct)      
      from round_robin_reschedule_correct[OF det invar'' ‹state_invar s, OF ‹state_α s  I this, of n0] None σ Cons invar
        round_robin_step_correct[OF det invar' ‹state_invar s, of n0 t]
      show ?thesis by(auto simp add: queue.isEmpty_correct queue.push_correct round_robin_α_def queue.enqueue_correct)
    qed
  qed
  thus ?thesis1 ?thesis2 by simp_all
qed

lemma round_robin_scheduler_spec:
  assumes det: "α.deterministic I"
  shows "scheduler_spec final r (round_robin n0) round_robin_invar thr_α thr_invar ws_α ws_invar is_α is_invar I"
proof
  fix σ s
  assume rr: "round_robin n0 σ s = None"
    and invar: "round_robin_invar σ (dom (thr_α (thr s)))" "state_invar s" "state_α s  I"
  from round_robin_correct[OF det, OF invar, of n0] rr
  have "α.round_robin n0 (round_robin_α σ) (state_α s) = None" by simp
  moreover from invar have "Round_Robin.round_robin_invar (round_robin_α σ) (dom (thr (state_α s)))"
    by(simp add: round_robin_invar_correct)
  ultimately show "α.active_threads (state_α s) = {}" by(rule α.round_robin_NoneD)
next
  fix σ s t σ'
  assume rr: "round_robin n0 σ s = (t, None, σ')"
    and invar: "round_robin_invar σ (dom (thr_α (thr s)))" "state_invar s" "state_α s  I"
  from round_robin_correct[OF det, OF invar, of n0] rr
  have rr': "α.round_robin n0 (round_robin_α σ) (state_α s) = (t, None, round_robin_α σ')" by simp
  then show "x ln n. thr_α (thr s) t = (x, ln)  0 < ln $ n  ¬ waiting (ws_α (wset s) t)  may_acquire_all (locks s) t ln"
    by(rule α.round_robin_Some_NoneD[where s="state_α s", unfolded state_α_conv])
next
  fix σ s t ta x' m' σ'
  assume rr: "round_robin n0 σ s = (t, (ta, x', m'), σ')"
    and invar: "round_robin_invar σ (dom (thr_α (thr s)))" "state_invar s" "state_α s  I"
  from round_robin_correct[OF det, OF invar, of n0] rr
  have rr': "α.round_robin n0 (round_robin_α σ) (state_α s) = (t, (ta, x', m'), round_robin_α σ')" by simp
  thus "x. thr_α (thr s) t = (x, no_wait_locks)  Predicate.eval (r t (x, shr s)) (ta, x', m')  α.actions_ok (state_α s) t ta"
    using ‹state_α s  I by(rule α.round_robin_Some_SomeD[OF det, where s="state_α s", unfolded state_α_conv])
next
  fix σ s t σ'
  assume rr: "round_robin n0 σ s = (t, None, σ')"
    and invar: "round_robin_invar σ (dom (thr_α (thr s)))" "state_invar s" "state_α s  I"
  from round_robin_correct[OF det, OF invar, of n0] rr
  show "round_robin_invar σ' (dom (thr_α (thr s)))" by simp
next
  fix σ s t ta x' m' σ'
  assume rr: "round_robin n0 σ s = (t, (ta, x', m'), σ')"
    and invar: "round_robin_invar σ (dom (thr_α (thr s)))" "state_invar s" "state_α s  I"
  from round_robin_correct[OF det, OF invar, of n0] rr
  show "round_robin_invar σ' (dom (thr_α (thr s))  {t. x m. NewThread t x m  set tat})" by simp
qed

lemma round_robin_start_invar:
  "round_robin_invar (round_robin_start n0 t0) {t0}"
by(simp add: round_robin_start_def queue.empty_correct queue.enqueue_correct)

end

sublocale round_robin_base <
  scheduler_base
    final r convert_RA
    "round_robin n0" "output" "pick_wakeup_via_sel (λs P. ws_sel s (λ(k,v). P k v))" round_robin_invar
    thr_α thr_invar thr_lookup thr_update
    ws_α ws_invar ws_lookup ws_update ws_delete ws_iterate
    is_α is_invar is_memb is_ins is_delete
  for n0 .

sublocale round_robin <
  pick_wakeup_spec
    final r convert_RA
    "pick_wakeup_via_sel (λs P. ws_sel s (λ(k,v). P k v))" round_robin_invar
    thr_α thr_invar
    ws_α ws_invar
    is_α is_invar
by(rule pick_wakeup_spec_via_sel)(unfold_locales)

context round_robin begin

lemma round_robin_scheduler:
  assumes det: "α.deterministic I"
  shows 
  "scheduler
     final r convert_RA
     (round_robin n0) (pick_wakeup_via_sel (λs P. ws_sel s (λ(k,v). P k v))) round_robin_invar 
     thr_α thr_invar thr_lookup thr_update 
     ws_α ws_invar ws_lookup ws_update ws_delete ws_iterate
     is_α is_invar is_memb is_ins is_delete
     I"
proof -
  interpret scheduler_spec
      final r convert_RA
      "round_robin n0" round_robin_invar
      thr_α thr_invar
      ws_α ws_invar
      is_α is_invar
      I
    using det by(rule round_robin_scheduler_spec)

  show ?thesis by(unfold_locales)(rule α.deterministic_invariant3p[OF det])
qed

end

lemmas [code] =
  round_robin_base.queue_rotate1_def
  round_robin_base.enqueue_new_thread.simps
  round_robin_base.enqueue_new_threads_def
  round_robin_base.round_robin_update_state.simps
  round_robin_base.round_robin_reschedule.simps
  round_robin_base.round_robin.simps
  round_robin_base.round_robin_start_def

end

Theory SC_Schedulers

theory SC_Schedulers
imports
  Random_Scheduler
  Round_Robin
  "../MM/SC_Collections"
  (*
  "../../Collections/impl/RBTMapImpl"
  "../../Collections/impl/RBTSetImpl"
  "../../Collections/impl/Fifo"
  "../../Collections/impl/ListSetImpl_Invar"
  *)
  "../Basic/JT_ICF"
  
begin

abbreviation sc_start_state_refine ::
  "'m_t  (thread_id  ('x × addr released_locks)  'm_t  'm_t)  'm_w  's_i
   (cname  mname  ty list  ty  'md  addr val list  'x)  'md prog  cname  mname  addr val list
   (addr, thread_id, heap, 'm_t, 'm_w, 's_i) state_refine"
where
  "is_empty.
   sc_start_state_refine thr_empty thr_update ws_empty is_empty f P 
   heap_base.start_state_refine addr2thread_id sc_empty (sc_allocate P) thr_empty thr_update ws_empty is_empty f P"

abbreviation sc_state_α ::
  "('l, 't :: linorder, 'm, ('t, 'x × 'l ⇒f nat) rm, ('t, 'w wait_set_status) rm, 't rs) state_refine
   ('l,'t,'x,'m,'w) state"
where "sc_state_α  state_refine_base.state_α rm_α rm_α rs_α"

lemma sc_state_α_sc_start_state_refine [simp]:
  "sc_state_α (sc_start_state_refine (rm_empty ()) rm_update (rm_empty ()) (rs_empty ()) f P C M vs) = sc_start_state f P C M vs"
by(simp add: heap_base.start_state_refine_def state_refine_base.state_α.simps split_beta sc.start_state_def rm_correct rs_correct)

locale sc_scheduler =
  scheduler
    final r convert_RA 
    schedule "output" pick_wakeup σ_invar
    rm_α rm_invar rm_lookup rm_update
    rm_α rm_invar rm_lookup rm_update rm_delete rm_iteratei
    rs_α rs_invar rs_memb rs_ins rs_delete
    invariant
  for final :: "'x  bool"
  and r :: "'t  ('x × 'm)  (('l,'t :: linorder,'x,'m,'w,'o) thread_action × 'x × 'm) Predicate.pred"
  and convert_RA :: "'l released_locks  'o list"
  and schedule :: "('l,'t,'x,'m,'w,'o,('t, 'x × 'l ⇒f nat) rm,('t, 'w wait_set_status) rm, 't rs, 's) scheduler"
  and "output" :: "'s  't  ('l,'t,'x,'m,'w,'o) thread_action  'q option"
  and pick_wakeup :: "'s  't  'w  ('t, 'w wait_set_status) RBT.rbt  't option"
  and σ_invar :: "'s  't set  bool"
  and invariant :: "('l,'t,'x,'m,'w) state set"

locale sc_round_robin_base =
  round_robin_base
    final r convert_RA "output"
    rm_α rm_invar rm_lookup rm_update 
    rm_α rm_invar rm_lookup rm_update rm_delete rm_iteratei rm_sel
    rs_α rs_invar rs_memb rs_ins rs_delete
    fifo_α fifo_invar fifo_empty fifo_isEmpty fifo_enqueue fifo_dequeue fifo_push
  for final :: "'x  bool"
  and r :: "'t  ('x × 'm)  (('l,'t :: linorder,'x,'m,'w,'o) thread_action × 'x × 'm) Predicate.pred"
  and convert_RA :: "'l released_locks  'o list"
  and "output" :: "'t fifo round_robin  't  ('l,'t,'x,'m,'w,'o) thread_action  'q option"

locale sc_round_robin =
  round_robin 
    final r convert_RA "output"
    rm_α rm_invar rm_lookup rm_update 
    rm_α rm_invar rm_lookup rm_update rm_delete rm_iteratei rm_sel
    rs_α rs_invar rs_memb rs_ins rs_delete
    fifo_α fifo_invar fifo_empty fifo_isEmpty fifo_enqueue fifo_dequeue fifo_push
  for final :: "'x  bool"
  and r :: "'t  ('x × 'm)  (('l,'t :: linorder,'x,'m,'w,'o) thread_action × 'x × 'm) Predicate.pred"
  and convert_RA :: "'l released_locks  'o list"
  and "output" :: "'t fifo round_robin  't  ('l,'t,'x,'m,'w,'o) thread_action  'q option"

sublocale sc_round_robin < sc_round_robin_base .

locale sc_random_scheduler_base =
  random_scheduler_base
    final r convert_RA "output"
    rm_α rm_invar rm_lookup rm_update rm_iteratei 
    rm_α rm_invar rm_lookup rm_update rm_delete rm_iteratei rm_sel
    rs_α rs_invar rs_memb rs_ins rs_delete
    lsi_α lsi_invar lsi_empty lsi_ins_dj lsi_to_list
  for final :: "'x  bool"
  and r :: "'t  ('x × 'm)  (('l,'t :: linorder,'x,'m,'w,'o) thread_action × 'x × 'm) Predicate.pred"
  and convert_RA :: "'l released_locks  'o list"
  and "output" :: "random_scheduler  't  ('l,'t,'x,'m,'w,'o) thread_action  'q option"

locale sc_random_scheduler =
  random_scheduler
    final r convert_RA "output"
    rm_α rm_invar rm_lookup rm_update rm_iteratei 
    rm_α rm_invar rm_lookup rm_update rm_delete rm_iteratei rm_sel
    rs_α rs_invar rs_memb rs_ins rs_delete
    lsi_α lsi_invar lsi_empty lsi_ins_dj lsi_to_list
  for final :: "'x  bool"
  and r :: "'t  ('x × 'm)  (('l,'t :: linorder,'x,'m,'w,'o) thread_action × 'x × 'm) Predicate.pred"
  and convert_RA :: "'l released_locks  'o list"
  and "output" :: "random_scheduler  't  ('l,'t,'x,'m,'w,'o) thread_action  'q option"

sublocale sc_random_scheduler < sc_random_scheduler_base .

text ‹No spurious wake-ups in generated code›
overloading sc_spurious_wakeups  sc_spurious_wakeups
begin
  definition sc_spurious_wakeups [code]: "sc_spurious_wakeups  False"
end

end

Theory TypeRelRefine

(*  Title:      JinjaThreads/Execute/TypeRelRefine.thy
    Author:     Andreas Lochbihler

    Tabulation for lookup functions
*)

section ‹Tabulation for lookup functions›

theory TypeRelRefine
imports
  "../Common/TypeRel"
  "HOL-Library.AList_Mapping"
begin

subsection ‹Auxiliary lemmata›

lemma rtranclp_tranclpE:
  assumes "r^** x y"
  obtains (refl) "x = y"
  | (trancl) "r^++ x y"
using assms
by(cases)(blast dest: rtranclp_into_tranclp1)+

lemma map_of_map2: "map_of (map (λ(k, v). (k, f k v)) xs) k = map_option (f k) (map_of xs k)"
by(induct xs) auto

lemma map_of_map_K: "map_of (map (λk. (k, c)) xs) k = (if k  set xs then Some c else None)"
by(induct xs) auto

lift_definition map_values :: "('a  'b  'c)  ('a, 'b) mapping  ('a, 'c) mapping"
is "λf m k. map_option (f k) (m k)" .

lemma map_values_Mapping [simp]: 
  "map_values f (Mapping.Mapping m) = Mapping.Mapping (λk. map_option (f k) (m k))"
by(rule map_values.abs_eq)

lemma map_Mapping: "Mapping.map f g (Mapping.Mapping m) = Mapping.Mapping (map_option g  m  f)"
by(rule map.abs_eq)

abbreviation subclst :: "'m prog  cname  cname  bool"
where "subclst P  (subcls1 P)^++"

subsection ‹Representation type for tabulated lookup functions›

type_synonym
  'm prog_impl' = 
  "'m cdecl list ×
   (cname, 'm class) mapping ×
   (cname, cname set) mapping × 
   (cname, (vname, cname × ty × fmod) mapping) mapping × 
   (cname, (mname, cname × ty list × ty × 'm option) mapping) mapping"

lift_definition tabulate_class :: "'m cdecl list  (cname, 'm class) mapping"
is "class  Program" .

lift_definition tabulate_subcls :: "'m cdecl list  (cname, cname set) mapping"
is "λP C. if is_class (Program P) C then Some {D. Program P  C * D} else None" .

lift_definition tabulate_sees_field :: "'m cdecl list  (cname, (vname, cname × ty × fmod) mapping) mapping"
is "λP C. if is_class (Program P) C then
        Some (λF. if T fm D. Program P  C sees F:T (fm) in D then Some (field (Program P) C F) else None)
      else None" .

lift_definition tabulate_Method :: "'m cdecl list  (cname, (mname, cname × ty list × ty × 'm option) mapping) mapping"
is "λP C. if is_class (Program P) C then
         Some (λM. if Ts T mthd D. Program P  C sees M:TsT=mthd in D then Some (method (Program P) C M) else None)
      else None" .

fun wf_prog_impl' :: "'m prog_impl'  bool"
where
  "wf_prog_impl' (P, c, s, f, m) 
  c = tabulate_class P 
  s = tabulate_subcls P 
  f = tabulate_sees_field P 
  m = tabulate_Method P"

subsection ‹Implementation type for tabulated lookup functions›

typedef 'm prog_impl = "{P :: 'm prog_impl'. wf_prog_impl' P}"
  morphisms impl_of ProgRefine 
proof
  show "([], Mapping.empty, Mapping.empty, Mapping.empty, Mapping.empty)  ?prog_impl"
    apply clarsimp
    by transfer (simp_all add: fun_eq_iff is_class_def rel_funI)
qed

lemma impl_of_ProgImpl [simp]:
  "wf_prog_impl' Pfsm  impl_of (ProgRefine Pfsm) = Pfsm"
by(simp add: ProgRefine_inverse)

definition program :: "'m prog_impl  'm prog"
where "program = Program  fst  impl_of"

code_datatype program

lemma prog_impl_eq_iff:
  "Pi = Pi'  program Pi = program Pi'" for Pi Pi'
apply(cases Pi)
apply(cases Pi')
apply(auto simp add: ProgRefine_inverse program_def ProgRefine_inject)
done

lemma wf_prog_impl'_impl_of [simp, intro!]:
  "wf_prog_impl' (impl_of Pi)" for Pi
using impl_of[of Pi] by simp

lemma ProgImpl_impl_of [simp, code abstype]:
  "ProgRefine (impl_of Pi) = Pi" for Pi
by(rule impl_of_inverse)

lemma program_ProgRefine [simp]: "wf_prog_impl' Psfm  program (ProgRefine Psfm) = Program (fst Psfm)"
by(simp add: program_def)

lemma classes_program [code]: "classes (program P) = fst (impl_of P)"
by(simp add: program_def)

lemma class_program [code]: "class (program Pi) = Mapping.lookup (fst (snd (impl_of Pi)))" for Pi
by(cases Pi)(clarsimp simp add: tabulate_class_def lookup.rep_eq Mapping_inverse)

subsection ‹Refining sub class and lookup functions to use precomputed mappings›

declare subcls'.equation [code del]

lemma subcls'_program [code]: 
  "subcls' (program Pi) C D  
  C = D 
  (case Mapping.lookup (fst (snd (snd (impl_of Pi)))) C of None  False
   | Some m  D  m)" for Pi
apply(cases Pi)
apply(clarsimp simp add: subcls'_def tabulate_subcls_def lookup.rep_eq Mapping_inverse)
apply(auto elim!: rtranclp_tranclpE dest: subcls_is_class intro: tranclp_into_rtranclp)
done

lemma subcls'_i_i_i_program [code]:
  "subcls'_i_i_i P C D = (if subcls' P C D then Predicate.single () else bot)"
by(rule pred_eqI)(auto elim: subcls'_i_i_iE intro: subcls'_i_i_iI)

lemma subcls'_i_i_o_program [code]:
  "subcls'_i_i_o (program Pi) C = 
  sup (Predicate.single C) (case Mapping.lookup (fst (snd (snd (impl_of Pi)))) C of None  bot | Some m  pred_of_set m)" for Pi
by(cases Pi)(fastforce simp add: subcls'_i_i_o_def subcls'_def tabulate_subcls_def lookup.rep_eq Mapping_inverse intro!: pred_eqI split: if_split_asm elim: rtranclp_tranclpE dest: subcls_is_class intro: tranclp_into_rtranclp)

lemma rtranclp_FioB_i_i_subcls1_i_i_o_code [code_unfold]:
  "rtranclp_FioB_i_i (subcls1_i_i_o P) = subcls'_i_i_i P"
by(auto simp add: fun_eq_iff subcls1_i_i_o_def subcls'_def rtranclp_FioB_i_i_def subcls'_i_i_i_def)

declare Method.equation[code del]
lemma Method_program [code]:
  "program Pi  C sees M:TsT=meth in D  
  (case Mapping.lookup (snd (snd (snd (snd (impl_of Pi))))) C of 
    None  False
  | Some m  
    (case Mapping.lookup m M of 
       None  False
     | Some (D', Ts', T', meth')  Ts = Ts'  T = T'  meth = meth'  D = D'))" for Pi
by(cases Pi)(auto split: if_split_asm dest: sees_method_is_class simp add: tabulate_Method_def lookup.rep_eq Mapping_inverse)

lemma Method_i_i_i_o_o_o_o_program [code]:
  "Method_i_i_i_o_o_o_o (program Pi) C M = 
  (case Mapping.lookup (snd (snd (snd (snd (impl_of Pi))))) C of
    None  bot
  | Some m 
    (case Mapping.lookup m M of
      None  bot
    | Some (D, Ts, T, meth)  Predicate.single (Ts, T, meth, D)))" for Pi
by(auto simp add: Method_i_i_i_o_o_o_o_def Method_program intro!: pred_eqI)

lemma Method_i_i_i_o_o_o_i_program [code]:
  "Method_i_i_i_o_o_o_i (program Pi) C M D = 
  (case Mapping.lookup (snd (snd (snd (snd (impl_of Pi))))) C of
    None  bot
  | Some m 
    (case Mapping.lookup m M of
      None  bot
    | Some (D', Ts, T, meth)  if D = D' then Predicate.single (Ts, T, meth) else bot))" for Pi
by(auto simp add: Method_i_i_i_o_o_o_i_def Method_program intro!: pred_eqI)

declare sees_field.equation[code del]

lemma sees_field_program [code]:
  "program Pi  C sees F:T (fd) in D 
  (case Mapping.lookup (fst (snd (snd (snd (impl_of Pi))))) C of
    None  False
  | Some m  
    (case Mapping.lookup m F of 
       None  False
     | Some (D', T', fd')  T = T'  fd = fd'  D = D'))" for Pi
by(cases Pi)(auto split: if_split_asm dest: has_visible_field[THEN has_field_is_class] simp add: tabulate_sees_field_def lookup.rep_eq Mapping_inverse)

lemma sees_field_i_i_i_o_o_o_program [code]:
  "sees_field_i_i_i_o_o_o (program Pi) C F =
  (case Mapping.lookup (fst (snd (snd (snd (impl_of Pi))))) C of
    None  bot
  | Some m 
    (case Mapping.lookup m F of
       None  bot
    | Some (D, T, fd)  Predicate.single(T, fd, D)))" for Pi
by(auto simp add: sees_field_program sees_field_i_i_i_o_o_o_def intro: pred_eqI)

lemma sees_field_i_i_i_o_o_i_program [code]:
  "sees_field_i_i_i_o_o_i (program Pi) C F D =
  (case Mapping.lookup (fst (snd (snd (snd (impl_of Pi))))) C of
    None  bot
  | Some m 
    (case Mapping.lookup m F of
       None  bot
    | Some (D', T, fd)  if D = D' then Predicate.single(T, fd) else bot))" for Pi
by(auto simp add: sees_field_program sees_field_i_i_i_o_o_i_def intro: pred_eqI)

lemma field_program [code]:
  "field (program Pi) C F = 
  (case Mapping.lookup (fst (snd (snd (snd (impl_of Pi))))) C of 
    None  Code.abort (STR ''not_unique'') (λ_. Predicate.the bot)
  | Some m  
    (case Mapping.lookup m F of
       None  Code.abort (STR ''not_unique'') (λ_. Predicate.the bot)
     | Some (D', T, fd)  (D', T, fd)))" for Pi
unfolding field_def
by(cases Pi)(fastforce simp add: Predicate.the_def tabulate_sees_field_def lookup.rep_eq Mapping_inverse split: if_split_asm intro: arg_cong[where f=The] dest: has_visible_field[THEN has_field_is_class] sees_field_fun)

subsection ‹Implementation for precomputing mappings›

definition tabulate_program :: "'m cdecl list  'm prog_impl"
where "tabulate_program P = ProgRefine (P, tabulate_class P, tabulate_subcls P, tabulate_sees_field P, tabulate_Method P)"

lemma impl_of_tabulate_program [code abstract]:
  "impl_of (tabulate_program P) = (P, tabulate_class P, tabulate_subcls P, tabulate_sees_field P, tabulate_Method P)"
by(simp add: tabulate_program_def)

lemma Program_code [code]:
  "Program = program  tabulate_program"
by(simp add: program_def fun_eq_iff tabulate_program_def)

subsubsection @{term "class" }

lemma tabulate_class_code [code]:
  "tabulate_class = Mapping.of_alist"
  by transfer (simp add: fun_eq_iff)

subsubsection @{term "subcls" }

inductive subcls1' :: "'m cdecl list  cname  cname  bool"
where 
  find: "C  Object  subcls1' ((C, D, rest) # P) C D"
| step: " C  Object; C  C'; subcls1' P C D    subcls1' ((C', D', rest) # P) C D"

code_pred
  (modes: i ⇒ i ⇒ o ⇒ bool)
  subcls1' .

lemma subcls1_into_subcls1':
  assumes "subcls1 (Program P) C D"
  shows "subcls1' P C D"
proof -
  from assms obtain rest where "map_of P C = (D, rest)" "C  Object" by cases simp
  thus ?thesis by(induct P)(auto split: if_split_asm intro: subcls1'.intros)
qed

lemma subcls1'_into_subcls1:
  assumes "subcls1' P C D"
  shows "subcls1 (Program P) C D"
using assms
proof(induct)
  case find thus ?case by(auto intro: subcls1.intros)
next
  case step thus ?case by(auto elim!: subcls1.cases intro: subcls1.intros)
qed

lemma subcls1_eq_subcls1':
  "subcls1 (Program P) = subcls1' P"
by(auto simp add: fun_eq_iff intro: subcls1_into_subcls1' subcls1'_into_subcls1)

definition subcls'' :: "'m cdecl list  cname  cname  bool"
where "subcls'' P = (subcls1' P)^**"

code_pred
  (modes: i ⇒ i ⇒ i ⇒ bool)
  [inductify] 
  subcls'' .

lemma subcls''_eq_subcls: "subcls'' P = subcls (Program P)"
by(simp add: subcls''_def subcls1_eq_subcls1')

lemma subclst_snd_classD: 
  assumes "subclst (Program P) C D"
  shows "D  fst ` snd ` set P"
using assms
by(induct)(fastforce elim!: subcls1.cases dest!: map_of_SomeD intro: rev_image_eqI)+

definition check_acyclicity :: "(cname, cname set) mapping  'm cdecl list  unit"
where "check_acyclicity _ _ = ()"

definition cyclic_class_hierarchy :: unit 
where [code del]: "cyclic_class_hierarchy = ()"

declare [[code abort: cyclic_class_hierarchy]]

lemma check_acyclicity_code:
  "check_acyclicity mapping P =
   (let _ = 
     map (λ(C, D, _).
       if C = Object then () 
       else
         (case Mapping.lookup mapping D of 
            None  ()
          | Some Cs  if C  Cs then cyclic_class_hierarchy else ()))
       P
    in ())"
by simp

lemma tablulate_subcls_code [code]:
  "tabulate_subcls P = 
  (let cnames = map fst P;
       cnames' = map (fst  snd) P;
       mapping = Mapping.tabulate cnames (λC. set (C # [D  cnames'. subcls'' P C D]));
       _ = check_acyclicity mapping P
   in mapping
  )"
apply(auto simp add: tabulate_subcls_def Mapping.tabulate_def fun_eq_iff is_class_def o_def map_of_map2[simplified split_def] Mapping_inject)
 apply(subst map_of_map2[simplified split_def])
 apply(auto simp add: fun_eq_iff subcls''_eq_subcls map_of_map_K dest: subclst_snd_classD elim: rtranclp_tranclpE)[1]
apply(subst map_of_map2[simplified split_def])
apply(rule sym)
apply simp
apply(case_tac "map_of P x")
apply auto
done

subsubsection @{term Fields}

text ‹
  Problem: Does not terminate for cyclic class hierarchies!
  This problem already occurs in Jinja's well-formedness checker: 
  wf_cdecl› calls wf_mdecl› before checking for acyclicity, 
  but wf_J_mdecl› involves the type judgements, 
  which in turn requires @{term "Fields"} (via @{term sees_field}).
  Checking acyclicity before executing @{term "Fields'"} for tabulation is difficult
  because we would have to intertwine tabulation and well-formedness checking.
  Possible (local) solution:
  additional termination parameter (like memoisation for @{term "rtranclp"}) 
  and list option as error return parameter.
›
inductive
  Fields' :: "'m cdecl list  cname  ((vname × cname) × (ty × fmod)) list  bool"
for P :: "'m cdecl list"
where 
  rec:
  " map_of P C = Some(D,fs,ms); C  Object; Fields' P D FDTs;
     FDTs' = map (λ(F,Tm). ((F,C),Tm)) fs @ FDTs 
   Fields' P C FDTs'"
| Object:
  " map_of P Object = Some(D,fs,ms); FDTs = map (λ(F,T). ((F,Object),T)) fs 
   Fields' P Object FDTs"

lemma Fields'_into_Fields:
  assumes "Fields' P C FDTs"
  shows "Program P  C has_fields FDTs"
using assms
by induct(auto intro: Fields.intros)

lemma Fields_into_Fields':
  assumes "Program P  C has_fields FDTs"
  shows "Fields' P C FDTs"
using assms
by induct(auto intro: Fields'.intros)

lemma Fields'_eq_Fields:
  "Fields' P = Fields (Program P)"
by(auto simp add: fun_eq_iff intro: Fields'_into_Fields Fields_into_Fields')

code_pred 
  (modes: i ⇒ i ⇒ o ⇒ bool)
  Fields' .

definition fields' :: "'m cdecl list  cname  ((vname × cname) × (ty × fmod)) list"
where "fields' P C = (if FDTs. Fields' P C FDTs then THE FDTs. Fields' P C FDTs else [])"

lemma eval_Fields'_conv:
  "Predicate.eval (Fields'_i_i_o P C) = Fields' P C"
by(auto intro: Fields'_i_i_oI elim: Fields'_i_i_oE intro!: ext)

lemma fields'_code [code]:
  "fields' P C = 
  (let FDTs = Fields'_i_i_o P C in if Predicate.holds (FDTs  (λ_. Predicate.single ())) then Predicate.the FDTs else [])"
by(auto simp add: fields'_def holds_eq Fields'_i_i_o_def intro: Fields'_i_i_oI Predicate.the_eqI[THEN sym])

lemma The_Fields [simp]:
  "P  C has_fields FDTs  The (Fields P C) = FDTs"
by(auto dest: has_fields_fun)

lemma tabulate_sees_field_code [code]:
  "tabulate_sees_field P =
   Mapping.tabulate (map fst P) (λC. Mapping.of_alist (map (λ((F, D), Tfm). (F, (D, Tfm))) (fields' P C)))"
apply(simp add: tabulate_sees_field_def tabulate_def is_class_def fields'_def Fields'_eq_Fields Mapping_inject)
apply(rule ext)
apply clarsimp
apply(rule conjI)
 apply(clarsimp simp add: o_def)
 apply(subst map_of_map2[unfolded split_def])
 apply simp
 apply transfer
 apply(rule conjI)
  apply clarsimp
  apply(rule ext)
  apply clarsimp
  apply(rule conjI)
   apply(clarsimp simp add: sees_field_def Fields'_eq_Fields)
   apply(drule (1) has_fields_fun, clarsimp)
  apply clarify
  apply(rule sym)
  apply(rule ccontr)
  apply(clarsimp simp add: sees_field_def Fields'_eq_Fields)
 apply clarsimp
 apply(rule ext)
 apply(clarsimp simp add: sees_field_def)
apply(clarsimp simp add: o_def)
apply(subst map_of_map2[simplified split_def])
apply(rule sym)
apply(clarsimp)
apply(rule ccontr)
apply simp
done

subsubsection @{term "Methods" }

text ‹Same termination problem as for @{term Fields'}
inductive Methods' :: "'m cdecl list  cname  (mname × (ty list × ty × 'm option) × cname) list  bool"
  for P :: "'m cdecl list"
where 
  " map_of P Object = Some(D,fs,ms); Mm = map (λ(M, rest). (M, (rest, Object))) ms 
    Methods' P Object Mm"
| " map_of P C = Some(D,fs,ms); C  Object; Methods' P D Mm;
     Mm' = map (λ(M, rest). (M, (rest, C))) ms @ Mm 
    Methods' P C Mm'"

lemma Methods'_into_Methods:
  assumes "Methods' P C Mm"
  shows "Program P  C sees_methods (map_of Mm)"
using assms
apply induct
 apply(clarsimp simp add: o_def split_def)
 apply(rule sees_methods_Object)
  apply fastforce
 apply(rule ext)
 apply(subst map_of_map2[unfolded split_def])
 apply(simp add: o_def)

apply(rule sees_methods_rec)
   apply fastforce
  apply simp
 apply assumption
apply(clarsimp simp add: map_add_def map_of_map2)
done

lemma Methods_into_Methods':
  assumes "Program P  C sees_methods Mm"
  shows "Mm'. Methods' P C Mm'  Mm = map_of Mm'"
using assms
by induct(auto intro: Methods'.intros simp add: map_of_map2 map_add_def)

code_pred 
  (modes: i ⇒ i ⇒ o ⇒ bool)
  Methods'
.

definition methods' :: "'m cdecl list  cname  (mname × (ty list × ty × 'm option) × cname) list"
where "methods' P C = (if Mm. Methods' P C Mm then THE Mm. Methods' P C Mm else [])"

lemma methods'_code [code]:
  "methods' P C =
  (let Mm = Methods'_i_i_o P C
   in if Predicate.holds (Mm  (λ_. Predicate.single ())) then Predicate.the Mm else [])"
unfolding methods'_def
by(auto simp add: holds_eq Methods'_i_i_o_def Predicate.the_def)

lemma Methods'_fun:
  assumes "Methods' P C Mm"
  shows "Methods' P C Mm'  Mm = Mm'"
using assms
apply(induct arbitrary: Mm')
 apply(fastforce elim: Methods'.cases)
apply(rotate_tac -1)
apply(erule Methods'.cases)
 apply(fastforce)
apply clarify
apply(simp)
done

lemma The_Methods' [simp]: "Methods' P C Mm  The (Methods' P C) = Mm"
by(auto dest: Methods'_fun)

lemma methods_def2 [simp]: "Methods' P C Mm  methods' P C = Mm"
by(auto simp add: methods'_def)

lemma tabulate_Method_code [code]:
  "tabulate_Method P =
   Mapping.tabulate (map fst P) (λC. Mapping.of_alist (map (λ(M, (rest, D)). (M, D, rest)) (methods' P C)))"
apply(simp add: tabulate_Method_def tabulate_def o_def lookup.rep_eq Mapping_inject)
apply(rule ext)
apply clarsimp
apply(rule conjI)
 apply clarify
 apply(rule sym)
 apply(subst map_of_map2[unfolded split_def])
 apply(simp add: is_class_def)
 apply transfer
 apply(rule ext)
 apply(simp add: map_of_map2)
 apply(rule conjI)
  apply(clarsimp simp add: map_of_map2 Method_def)
  apply(drule Methods_into_Methods')
  apply clarsimp
  apply(simp add: split_def)
  apply(subst map_of_map2[unfolded split_def])
  apply simp
 apply clarify
 apply(clarsimp simp add: methods'_def)
 apply(frule Methods'_into_Methods)
 apply(clarsimp simp add: Method_def)
 apply(simp add: split_def)
 apply(subst map_of_map2[unfolded split_def])
 apply(fastforce intro: ccontr)
apply clarify
apply(rule sym)
apply(simp add: map_of_eq_None_iff is_class_def)
apply(simp only: set_map[symmetric] map_map o_def fst_conv)
apply simp
done

text ‹Merge modules TypeRel, Decl and TypeRelRefine to avoid cyclic modules›

code_identifier
  code_module TypeRel 
    (SML) TypeRel and (Haskell) TypeRel and (OCaml) TypeRel
| code_module TypeRelRefine 
    (SML) TypeRel and (Haskell) TypeRel and (OCaml) TypeRel
| code_module Decl 
    (SML) TypeRel and (Haskell) TypeRel and (OCaml) TypeRel

ML_val @{code Program}

end

Theory PCompilerRefine

(*  Title:      JinjaThreads/Execute/PCompilerRefine.thy
    Author:     Andreas Lochbihler

    Tabulation for the compiler
*)

theory PCompilerRefine
imports
  TypeRelRefine
  "../Compiler/PCompiler"
begin

subsection @{term "compP"}

text ‹
  Applying the compiler to a tabulated program either compiles every
  method twice (once for the program itself and once for method lookup)
  or recomputes the class and method lookup tabulation from scratch.
  We follow the second approach.
›

fun compP_code' :: "(cname  mname  ty list  ty  'a  'b)  'a prog_impl'  'b prog_impl'"
where
  "compP_code' f (P, Cs, s, F, m) = 
  (let P' = map (compC f) P
   in (P', tabulate_class P', s, F, tabulate_Method P'))"

definition compP_code :: "(cname  mname  ty list  ty  'a  'b)  'a prog_impl  'b prog_impl"
where "compP_code f P = ProgRefine (compP_code' f (impl_of P))"

declare compP.simps [simp del] compP.simps[symmetric, simp]

lemma compP_code_code [code abstract]:
  "impl_of (compP_code f P) = compP_code' f (impl_of P)"
apply(cases P)
apply(simp add: compP_code_def)
apply(subst ProgRefine_inverse)
apply(auto simp add: tabulate_subcls_def tabulate_sees_field_def Mapping_inject intro!: ext)
done

declare compP.simps [simp] compP.simps[symmetric, simp del]

lemma compP_program [code]:
  "compP f (program P) = program (compP_code f P)"
by(cases P)(clarsimp simp add: program_def compP_code_code)

text ‹Merge module names to avoid cycles in module dependency›

code_identifier
  code_module PCompiler 
    (SML) PCompiler and (OCaml) PCompiler and (Haskell) PCompiler 
| code_module PCompilerRefine 
    (SML) PCompiler and (OCaml) PCompiler and (Haskell) PCompiler 

ML_val @{code compP}

end

Theory J_Execute

(*  Title:      JinjaThreads/Execute/J_Execute.thy
    Author:     Andreas Lochbihler
*)

section ‹Executable semantics for J›

theory J_Execute
imports
  SC_Schedulers
  "../J/Threaded"
begin

interpretation sc:
  J_heap_base
    "addr2thread_id"
    "thread_id2addr"
    "sc_spurious_wakeups"
    "sc_empty"
    "sc_allocate P"
    "sc_typeof_addr"
    "sc_heap_read"
    "sc_heap_write"
  for P .

abbreviation sc_red ::
  "((addr, thread_id, heap) external_thread_action  (addr, thread_id, 'o, heap) Jinja_thread_action)
   addr J_prog  thread_id  addr expr  heap × addr locals
   (addr, thread_id, 'o, heap) Jinja_thread_action  addr expr  heap × addr locals  bool"
  ("_,_,_ ⊢sc ((1_,/_) -_/ (1_,/_))" [51,51,0,0,0,0,0,0] 81)
where
  "sc_red extTA P  sc.red (TYPE(addr J_mb)) P extTA P"

fun sc_red_i_i_i_i_i_i_i_i_Fii_i_oB_Fii_i_i_oB_i_i_i_i_i_o_o_o
where
  "sc_red_i_i_i_i_i_i_i_i_Fii_i_oB_Fii_i_i_oB_i_i_i_i_i_o_o_o P t ((e, xs), h) =
  red_i_i_i_i_i_i_Fii_i_oB_Fii_i_i_oB_i_i_i_i_i_o_o_o
    addr2thread_id thread_id2addr sc_spurious_wakeups
    sc_empty (sc_allocate P) sc_typeof_addr sc_heap_read_i_i_i_o sc_heap_write_i_i_i_i_o
    (extTA2J P) P t e (h, xs)
   (λ(ta, e, h, xs). Predicate.single (ta, (e, xs), h))"

abbreviation sc_J_start_state_refine ::
  "addr J_prog  cname  mname  addr val list 
  (addr, thread_id, heap, (thread_id, (addr expr × addr locals) × addr released_locks) rm, (thread_id, addr wait_set_status) rm, thread_id rs) state_refine"
where
  "sc_J_start_state_refine 
   sc_start_state_refine
     (rm_empty ()) rm_update (rm_empty ()) (rs_empty ())
     (λC M Ts T (pns, body) vs. (blocks (this # pns) (Class C # Ts) (Null # vs) body, Map.empty))"

lemma eval_sc_red_i_i_i_i_i_Fii_i_oB_Fii_i_i_oB_i_i_i_i_i_o_o_o:
  "(λt xm ta x'm'. Predicate.eval (sc_red_i_i_i_i_i_i_i_i_Fii_i_oB_Fii_i_i_oB_i_i_i_i_i_o_o_o P t xm) (ta, x'm')) =
  (λt ((e, xs), h) ta ((e', xs'), h'). extTA2J P,P,t ⊢sc e, (h, xs) -ta e', (h', xs'))"
by(auto elim!: red_i_i_i_i_i_i_Fii_i_oB_Fii_i_i_oB_i_i_i_i_i_o_o_oE intro!: red_i_i_i_i_i_i_Fii_i_oB_Fii_i_i_oB_i_i_i_i_i_o_o_oI ext SUP1_I simp add: eval_sc_heap_write_i_i_i_i_o eval_sc_heap_read_i_i_i_o)

lemma sc_J_start_state_invar: "(λ_. True) (sc_state_α (sc_J_start_state_refine P C M vs))"
by simp

subsection ‹Round-robin scheduler›

interpretation J_rr:
  sc_round_robin_base
    final_expr "sc_red_i_i_i_i_i_i_i_i_Fii_i_oB_Fii_i_i_oB_i_i_i_i_i_o_o_o P" convert_RA Jinja_output
  for P
.

definition sc_rr_J_start_state :: "nat  'm prog  thread_id fifo round_robin"
where "sc_rr_J_start_state n0 P = J_rr.round_robin_start n0 (sc_start_tid P)"

definition exec_J_rr ::
  "nat  addr J_prog  cname  mname  addr val list 
  (thread_id × (addr, thread_id) obs_event list,
   (addr, thread_id) locks × ((thread_id, (addr expr × addr locals) × addr released_locks) rm × heap) ×
   (thread_id, addr wait_set_status) rm × thread_id rs) tllist"
where
  "exec_J_rr n0 P C M vs = J_rr.exec P n0 (sc_rr_J_start_state n0 P) (sc_J_start_state_refine P C M vs)"

interpretation J_rr:
  sc_round_robin
    final_expr "sc_red_i_i_i_i_i_i_i_i_Fii_i_oB_Fii_i_i_oB_i_i_i_i_i_o_o_o P" convert_RA Jinja_output
  for P
by(unfold_locales)

interpretation J_rr:
  sc_scheduler
    final_expr "sc_red_i_i_i_i_i_i_i_i_Fii_i_oB_Fii_i_i_oB_i_i_i_i_i_o_o_o P" convert_RA
    "J_rr.round_robin P n0" Jinja_output "pick_wakeup_via_sel (λs P. rm_sel s (λ(k,v). P k v))" J_rr.round_robin_invar
    UNIV
  for P n0
unfolding sc_scheduler_def
apply(rule J_rr.round_robin_scheduler)
apply(unfold eval_sc_red_i_i_i_i_i_Fii_i_oB_Fii_i_i_oB_i_i_i_i_i_o_o_o)
apply(rule sc.red_mthr_deterministic[OF sc_deterministic_heap_ops])
apply(simp add: sc_spurious_wakeups)
done

subsection ‹Random scheduler›

interpretation J_rnd:
  sc_random_scheduler_base
    final_expr "sc_red_i_i_i_i_i_i_i_i_Fii_i_oB_Fii_i_i_oB_i_i_i_i_i_o_o_o P" convert_RA Jinja_output
  for P
.

definition sc_rnd_J_start_state :: "Random.seed  random_scheduler"
where "sc_rnd_J_start_state seed = seed"

definition exec_J_rnd ::
  "Random.seed  addr J_prog  cname  mname  addr val list 
  (thread_id × (addr, thread_id) obs_event list,
   (addr, thread_id) locks × ((thread_id, (addr expr × addr locals) × addr released_locks) rm × heap) ×
   (thread_id, addr wait_set_status) rm × thread_id rs) tllist"
where
  "exec_J_rnd seed P C M vs = J_rnd.exec P (sc_rnd_J_start_state seed) (sc_J_start_state_refine P C M vs)"

interpretation J_rnd:
  sc_random_scheduler
    final_expr "sc_red_i_i_i_i_i_i_i_i_Fii_i_oB_Fii_i_i_oB_i_i_i_i_i_o_o_o P" convert_RA Jinja_output
  for P
by(unfold_locales)

interpretation J_rnd:
  sc_scheduler
    final_expr "sc_red_i_i_i_i_i_i_i_i_Fii_i_oB_Fii_i_i_oB_i_i_i_i_i_o_o_o P" convert_RA
    "J_rnd.random_scheduler P" Jinja_output "pick_wakeup_via_sel (λs P. rm_sel s (λ(k,v). P k v))" "λ_ _. True"
    UNIV
  for P
unfolding sc_scheduler_def
apply(rule J_rnd.random_scheduler_scheduler)
apply(unfold eval_sc_red_i_i_i_i_i_Fii_i_oB_Fii_i_i_oB_i_i_i_i_i_o_o_o)
apply(rule sc.red_mthr_deterministic[OF sc_deterministic_heap_ops])
apply(simp add: sc_spurious_wakeups)
done

ML_val @{code exec_J_rr}

ML_val @{code exec_J_rnd}

end

Theory ExternalCall_Execute

(*  Title:      JinjaThreads/Execute/ExternalCall_Execute.thy
    Author:     Andreas Lochbihler
*)

section ‹Executable semantics for the JVM›

theory ExternalCall_Execute
imports
  "../Common/ExternalCall"
  "../Basic/Set_without_equal"
begin

subsection ‹Translated versions of external calls for the JVM›

locale heap_execute = addr_base +
  constrains addr2thread_id :: "('addr :: addr)  'thread_id" 
  and thread_id2addr :: "'thread_id  'addr" 
  fixes spurious_wakeups :: bool
  and empty_heap :: "'heap" 
  and allocate :: "'heap  htype  ('heap × 'addr) set" 
  and typeof_addr :: "'heap  'addr  htype option" 
  and heap_read :: "'heap  'addr  addr_loc  'addr val set" 
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap set"

sublocale heap_execute < execute: heap_base
  addr2thread_id thread_id2addr 
  spurious_wakeups
  empty_heap allocate typeof_addr
  "λh a ad v. v  heap_read h a ad" "λh a ad v h'. h'  heap_write h a ad v"
.

context heap_execute begin

definition heap_copy_loc :: "'addr  'addr  addr_loc  'heap  (('addr, 'thread_id) obs_event list × 'heap) set"
where [simp]:
  "heap_copy_loc a a' al h = {(obs, h'). execute.heap_copy_loc a a' al h obs h'}"

lemma heap_copy_loc_code:
  "heap_copy_loc a a' al h =
   (do {
      v  heap_read h a al;
      h'  heap_write h a' al v;
      {([ReadMem a al v, WriteMem a' al v], h')}
   })"
by(auto simp add: execute.heap_copy_loc.simps)

definition heap_copies :: "'addr  'addr  addr_loc list  'heap  (('addr, 'thread_id) obs_event list × 'heap) set"
where [simp]: "heap_copies a a' al h = {(obs, h'). execute.heap_copies a a' al h obs h'}"

lemma heap_copies_code:
  shows heap_copies_Nil: 
  "heap_copies a a' [] h = {([], h)}"
  and heap_copies_Cons:
  "heap_copies a a' (al # als) h =
  (do {
     (ob, h')  heap_copy_loc a a' al h;
     (obs, h'')  heap_copies a a' als h';
     {(ob @ obs, h'')}
  })"
by(fastforce elim!: execute.heap_copies_cases intro: execute.heap_copies.intros)+

definition heap_clone :: "'m prog  'heap  'addr  ('heap × (('addr, 'thread_id) obs_event list × 'addr) option) set"
where [simp]: "heap_clone P h a = {(h', obsa). execute.heap_clone P h a h' obsa}"

lemma heap_clone_code:
  "heap_clone P h a =
  (case typeof_addr h a of
    Class_type C  
      let HA = allocate h (Class_type C) 
      in if HA = {} then {(h, None)} else do {
          (h', a')  HA;
          FDTs  set_of_pred (Fields_i_i_o P C);
          (obs, h'')  heap_copies a a' (map (λ((F, D), Tfm). CField D F) FDTs) h';
          {(h'', (NewHeapElem a' (Class_type C) # obs, a'))}
        }
  | Array_type T n  
      let HA = allocate h (Array_type T n)
      in if HA = {} then {(h, None)} else do {
        (h', a')  HA;
        FDTs  set_of_pred (Fields_i_i_o P Object);
        (obs, h'')  heap_copies a a' (map (λ((F, D), Tfm). CField D F) FDTs @ map ACell [0..<n]) h';
        {(h'', (NewHeapElem a' (Array_type T n) # obs, a'))}
      }
  | _  {})"
  by (auto 4 3 elim!: execute.heap_clone.cases split: ty.splits
  prod.split_asm htype.splits intro: execute.heap_clone.intros
  simp add: eval_Fields_conv split_beta prod_eq_iff)
    (auto simp add: eval_Fields_conv Bex_def)

definition red_external_aggr :: 
  "'m prog  'thread_id  'addr  mname  'addr val list  'heap  
  (('addr, 'thread_id, 'heap) external_thread_action × 'addr extCallRet × 'heap) set"
where [simp]:
  "red_external_aggr P t a M vs h = execute.red_external_aggr P t a M vs h"

lemma red_external_aggr_code:
  "red_external_aggr P t a M vs h =
   (if M = wait then
      let ad_t = thread_id2addr t
      in {(Unlocka, Locka, IsInterrupted t True, ClearInterrupt t, ObsInterrupted t, execute.RetEXC InterruptedException, h),
          (Suspend a, Unlocka, Locka, ReleaseAcquirea, IsInterrupted t False, SyncUnlock a, RetStaySame, h),
          (UnlockFaila, execute.RetEXC IllegalMonitorState, h),
          (Notified, RetVal Unit, h),
          (WokenUp, ClearInterrupt t, ObsInterrupted t, execute.RetEXC InterruptedException, h)} 
          (if spurious_wakeups then {(Unlocka, Locka, ReleaseAcquirea, IsInterrupted t False, SyncUnlock a, RetVal Unit, h)} else {})
    else if M = notify then
       {(Notify a, Unlocka, Locka, RetVal Unit, h),
        (UnlockFaila, execute.RetEXC IllegalMonitorState, h)}
    else if M = notifyAll then 
       {(NotifyAll a, Unlocka, Locka , RetVal Unit, h),
        (UnlockFaila, execute.RetEXC IllegalMonitorState, h)}
    else if M = clone then
       do {
         (h', obsa)  heap_clone P h a;
         {case obsa of None  (ε, execute.RetEXC OutOfMemory, h')
           | Some (obs, a')  ((K$ [], [], [], [], [], obs), RetVal (Addr a'), h')}
       }
    else if M = hashcode then {(ε, RetVal (Intg (word_of_int (hash_addr a))), h)}
    else if M = print then {(ExternalCall a M vs Unit, RetVal Unit, h)}
    else if M = currentThread then {(ε, RetVal (Addr (thread_id2addr t)), h)}
    else if M = interrupted then 
      {(IsInterrupted t True, ClearInterrupt t, ObsInterrupted t, RetVal (Bool True), h),
       (IsInterrupted t False, RetVal (Bool False), h)}
    else if M = yield then {(Yield, RetVal Unit, h)}
    else
      let T = ty_of_htype (the (typeof_addr h a))
      in if P  T  Class Thread then
        let t_a = addr2thread_id a 
        in if M = start then 
             {(NewThread t_a (the_Class T, run, a) h, ThreadStart t_a, RetVal Unit, h),
              (ThreadExists t_a True, execute.RetEXC IllegalThreadState, h)}
           else if M = join then
             {(Join t_a, IsInterrupted t False, ThreadJoin t_a, RetVal Unit, h),
              (IsInterrupted t True, ClearInterrupt t, ObsInterrupted t, execute.RetEXC InterruptedException, h)}
           else if M = interrupt then
             {(ThreadExists t_a True, WakeUp t_a, Interrupt t_a, ObsInterrupt t_a, RetVal Unit, h),
              (ThreadExists t_a False, RetVal Unit, h)}
           else if M = isInterrupted then
             {(IsInterrupted t_a False, RetVal (Bool False), h),
              (IsInterrupted t_a True, ObsInterrupted t_a, RetVal (Bool True), h)}
         else {(, undefined)}
    else {(, undefined)})"
by (auto simp add: execute.red_external_aggr_def
  split del: option.splits) auto

end

lemmas [code] =
  heap_execute.heap_copy_loc_code
  heap_execute.heap_copies_code
  heap_execute.heap_clone_code
  heap_execute.red_external_aggr_code

end

Theory JVMExec_Execute2

(*  Title:      JinjaThreads/Execute/JVMExec_Execute2.thy
    Author:     Andreas Lochbihler
*)

section ‹An optimized JVM›

theory JVMExec_Execute2
imports
  "../BV/BVNoTypeError"
  ExternalCall_Execute
begin

text ‹
  This JVM must lookup the method declaration of the top call frame at every step to find the next instruction.
  It is more efficient to refine it such that the instruction list and the exception table are
  cached in the call frame. Even further, this theory adds keeps track of @{term "drop pc ins"}, 
  whose head is the next instruction to execute. 
›

locale JVM_heap_execute = heap_execute +
  constrains addr2thread_id :: "('addr :: addr)  'thread_id" 
  and thread_id2addr :: "'thread_id  'addr" 
  and spurious_wakeups :: bool
  and empty_heap :: "'heap" 
  and allocate :: "'heap  htype  ('heap × 'addr) set"
  and typeof_addr :: "'heap  'addr  htype option" 
  and heap_read :: "'heap  'addr  addr_loc  'addr val set" 
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap set"

sublocale JVM_heap_execute < execute: JVM_heap_base
  addr2thread_id thread_id2addr 
  spurious_wakeups
  empty_heap allocate typeof_addr
  "λh a ad v. v  heap_read h a ad" "λh a ad v h'. h'  heap_write h a ad v"
.

type_synonym
  'addr frame' = "('addr instr list × 'addr instr list × ex_table) × 'addr val list × 'addr val list × cname × mname × pc"

type_synonym
  ('addr, 'heap) jvm_state' = "'addr option × 'heap × 'addr frame' list"  

type_synonym
  'addr jvm_thread_state' = "'addr option × 'addr frame' list"

type_synonym
  ('addr, 'thread_id, 'heap) jvm_thread_action' = "('addr, 'thread_id, 'addr jvm_thread_state','heap) Jinja_thread_action"

type_synonym
  ('addr, 'thread_id, 'heap) jvm_ta_state' = "('addr, 'thread_id, 'heap) jvm_thread_action' × ('addr, 'heap) jvm_state'"

fun frame'_of_frame :: "'addr jvm_prog  'addr frame  'addr frame'"
where
  "frame'_of_frame P (stk, loc, C, M, pc) = 
  ((drop pc (instrs_of P C M), instrs_of P C M, ex_table_of P C M), stk, loc, C, M, pc)"

fun jvm_state'_of_jvm_state :: "'addr jvm_prog  ('addr, 'heap) jvm_state  ('addr, 'heap) jvm_state'"
where "jvm_state'_of_jvm_state P (xcp, h, frs) = (xcp, h, map (frame'_of_frame P) frs)"

fun jvm_thread_state'_of_jvm_thread_state :: "'addr jvm_prog  'addr jvm_thread_state  'addr jvm_thread_state'"
where
  "jvm_thread_state'_of_jvm_thread_state P (xcp, frs) = (xcp, map (frame'_of_frame P) frs)"

definition jvm_thread_action'_of_jvm_thread_action :: 
  "'addr jvm_prog  ('addr, 'thread_id, 'heap) jvm_thread_action  ('addr, 'thread_id, 'heap) jvm_thread_action'"
where
  "jvm_thread_action'_of_jvm_thread_action P = convert_extTA (jvm_thread_state'_of_jvm_thread_state P)"

fun jvm_ta_state'_of_jvm_ta_state :: 
  "'addr jvm_prog  ('addr, 'thread_id, 'heap) jvm_ta_state  ('addr, 'thread_id, 'heap) jvm_ta_state'"
where
  "jvm_ta_state'_of_jvm_ta_state P (ta, s) = (jvm_thread_action'_of_jvm_thread_action P ta, jvm_state'_of_jvm_state P s)"

abbreviation (input) frame_of_frame' :: "'addr frame'  'addr frame"
where "frame_of_frame'  snd"

definition jvm_state_of_jvm_state' :: "('addr, 'heap) jvm_state'  ('addr, 'heap) jvm_state"
where [simp]: 
  "jvm_state_of_jvm_state' = map_prod id (map_prod id (map frame_of_frame'))"

definition jvm_thread_state_of_jvm_thread_state' :: "'addr jvm_thread_state'  'addr jvm_thread_state"
where [simp]:
  "jvm_thread_state_of_jvm_thread_state' = map_prod id (map frame_of_frame')"

definition jvm_thread_action_of_jvm_thread_action' ::
  "('addr, 'thread_id, 'heap) jvm_thread_action'  ('addr, 'thread_id, 'heap) jvm_thread_action"
where [simp]:
  "jvm_thread_action_of_jvm_thread_action' = convert_extTA jvm_thread_state_of_jvm_thread_state'"

definition jvm_ta_state_of_jvm_ta_state' ::
  "('addr, 'thread_id, 'heap) jvm_ta_state'  ('addr, 'thread_id, 'heap) jvm_ta_state"
where [simp]:
  "jvm_ta_state_of_jvm_ta_state' = map_prod jvm_thread_action_of_jvm_thread_action' jvm_state_of_jvm_state'"

fun frame'_ok :: "'addr jvm_prog  'addr frame'  bool"
where 
  "frame'_ok P ((ins', insxt), stk, loc, C, M, pc)  
  ins' = drop pc (instrs_of P C M)  insxt = snd (snd (the (snd (snd (snd (method P C M))))))"

lemma frame'_ok_frame'_of_frame [iff]: 
  "frame'_ok P (frame'_of_frame P f)"
by(cases f)(simp)

lemma frames'_ok_inverse [simp]:
  "xset frs. frame'_ok P x  map (frame'_of_frame P  frame_of_frame') frs = frs"
by(rule map_idI) auto

fun jvm_state'_ok :: "'addr jvm_prog  ('addr, 'heap) jvm_state'  bool"
where "jvm_state'_ok P (xcp, h, frs) = (f  set frs. frame'_ok P f)"

lemma jvm_state'_ok_jvm_state'_of_jvm_state [iff]:
  "jvm_state'_ok P (jvm_state'_of_jvm_state P s)"
by(cases s) simp

fun jvm_thread_state'_ok :: "'addr jvm_prog  'addr jvm_thread_state'  bool"
where "jvm_thread_state'_ok P (xcp, frs)  (f  set frs. frame'_ok P f)"

lemma jvm_thread_state'_ok_jvm_thread_state'_of_jvm_thread_state [iff]:
  "jvm_thread_state'_ok P (jvm_thread_state'_of_jvm_thread_state P s)"
by(cases s) simp

definition jvm_thread_action'_ok :: "'addr jvm_prog  ('addr, 'thread_id, 'heap) jvm_thread_action'  bool"
where "jvm_thread_action'_ok P ta  (nt  set tat. t x h. nt = NewThread t x h  jvm_thread_state'_ok P x)"

lemma jvm_thread_action'_ok_jvm_thread_action'_of_jvm_thread_action [iff]:
  "jvm_thread_action'_ok P (jvm_thread_action'_of_jvm_thread_action P ta)"
by(cases ta)(fastforce dest: sym simp add: jvm_thread_action'_ok_def jvm_thread_action'_of_jvm_thread_action_def)

lemma jvm_thread_action'_ok_ε [simp]: "jvm_thread_action'_ok P ε"
by(simp add: jvm_thread_action'_ok_def)

fun jvm_ta_state'_ok :: "'addr jvm_prog  ('addr, 'thread_id, 'heap) jvm_ta_state'  bool"
where "jvm_ta_state'_ok P (ta, s)  jvm_thread_action'_ok P ta  jvm_state'_ok P s"

lemma jvm_ta_state'_ok_jvm_ta_state'_of_jvm_ta_state [iff]:
  "jvm_ta_state'_ok P (jvm_ta_state'_of_jvm_ta_state P tas)"
by(cases tas)(simp)

lemma frame_of_frame'_inverse [simp]: "frame_of_frame'  frame'_of_frame P = id"
by(clarsimp simp add: fun_eq_iff)

lemma convert_new_thread_action_frame_of_frame'_inverse [simp]:
  "convert_new_thread_action (map_prod id (map frame_of_frame'))  convert_new_thread_action (jvm_thread_state'_of_jvm_thread_state P) = id"
by(auto intro!: convert_new_thread_action_eqI simp add: fun_eq_iff List.map.id)

primrec extRet2JVM' :: 
  "'addr instr list  'addr instr list  ex_table 
   nat  'heap  'addr val list  'addr val list  cname  mname  pc  'addr frame' list 
   'addr extCallRet  ('addr, 'heap) jvm_state'"
where
  "extRet2JVM' ins' ins xt n h stk loc C M pc frs (RetVal v) = (None, h, ((tl ins', ins, xt), v # drop (Suc n) stk, loc, C, M, pc + 1) # frs)"
| "extRet2JVM' ins' ins xt n h stk loc C M pc frs (RetExc a) = (a, h, ((ins', ins, xt), stk, loc, C, M, pc) # frs)"
| "extRet2JVM' ins' ins xt n h stk loc C M pc frs RetStaySame = (None, h, ((ins', ins, xt), stk, loc, C, M, pc) # frs)"

definition extNTA2JVM' :: "'addr jvm_prog  (cname × mname × 'addr)  'addr jvm_thread_state'"
where "extNTA2JVM' P  (λ(C, M, a). let (D,Ts,T,meth) = method P C M; (mxs,mxl0,ins,xt) = the meth
                                   in (None, [((ins, ins, xt), [],Addr a # replicate mxl0 undefined_value, D, M, 0)]))"

abbreviation extTA2JVM' :: 
  "'addr jvm_prog  ('addr, 'thread_id, 'heap) external_thread_action  ('addr, 'thread_id, 'heap) jvm_thread_action'"
where "extTA2JVM' P  convert_extTA (extNTA2JVM' P)"

lemma jvm_state'_ok_extRet2JVM' [simp]:
  assumes [simp]: "ins = instrs_of P C M" "xt = ex_table_of P C M" "f  set frs. frame'_ok P f"
  shows "jvm_state'_ok P (extRet2JVM' (drop pc ins) ins xt n h stk loc C M pc frs va)"
by(cases va)(simp_all add: drop_tl drop_Suc)

lemma jvm_state'_of_jvm_state_extRet2JVM [simp]:
  assumes [simp]: "ins = instrs_of P C M" "xt = ex_table_of P C M" "f  set frs. frame'_ok P f"
  shows 
  "jvm_state'_of_jvm_state P (extRet2JVM n h' stk loc C M pc (map frame_of_frame' frs) va) =
   extRet2JVM' (drop pc (instrs_of P C M)) ins xt n h' stk loc C M pc frs va"
by(cases va)(simp_all add: drop_tl drop_Suc)

lemma extRet2JVM'_extRet2JVM [simp]:
  "jvm_state_of_jvm_state' (extRet2JVM' ins' ins xt n h' stk loc C M pc frs va) =
   extRet2JVM n h' stk loc C M pc (map frame_of_frame' frs) va"
by(cases va) simp_all


lemma jvm_ta_state'_ok_inverse:
  assumes "jvm_ta_state'_ok P tas" 
  shows "jvm_ta_state_of_jvm_ta_state' tas  A  tas  jvm_ta_state'_of_jvm_ta_state P ` A"
using assms
apply(cases tas)
apply(fastforce simp add: o_def jvm_thread_action'_of_jvm_thread_action_def jvm_thread_action'_ok_def intro!: map_idI[symmetric] map_idI convert_new_thread_action_eqI dest: bspec intro!: rev_image_eqI elim!: rev_iffD1[OF _ arg_cong[where f="λx. x : A"]])
done


context JVM_heap_execute begin

primrec exec_instr ::
  "'addr instr list  'addr instr list  ex_table 
   'addr instr  'addr jvm_prog  'thread_id  'heap  'addr val list  'addr val list
   cname  mname  pc  'addr frame' list 
   (('addr, 'thread_id, 'heap) jvm_ta_state') set"
where
  "exec_instr ins' ins xt (Load n) P t h stk loc C0 M0 pc frs = 
   {(ε, (None, h, ((tl ins', ins, xt), (loc ! n) # stk, loc, C0, M0, pc+1)#frs))}"
| "exec_instr ins' ins xt (Store n) P t h stk loc C0 M0 pc frs = 
   {(ε, (None, h, ((tl ins', ins, xt), tl stk, loc[n:=hd stk], C0, M0, pc+1)#frs))}"
| "exec_instr ins' ins xt (Push v) P t h stk loc C0 M0 pc frs = 
   {(ε, (None, h, ((tl ins', ins, xt), v # stk, loc, C0, M0, pc+1)#frs))}"
| "exec_instr ins' ins xt (New C) P t h stk loc C0 M0 pc frs = 
   (let HA = allocate h (Class_type C)
    in if HA = {} then {(ε, execute.addr_of_sys_xcpt OutOfMemory, h, ((ins', ins, xt), stk, loc, C0, M0, pc) # frs)}
       else do { (h', a)  HA;
          {(NewHeapElem a (Class_type C), None, h', ((tl ins', ins, xt), Addr a # stk, loc, C0, M0, pc + 1)#frs)}})"
| "exec_instr ins' ins xt (NewArray T) P t h stk loc C0 M0 pc frs =
   (let si = the_Intg (hd stk);
        i = nat (sint si)
     in if si <s 0
        then {(ε, execute.addr_of_sys_xcpt NegativeArraySize, h, ((ins', ins, xt), stk, loc, C0, M0, pc) # frs)}
        else let HA = allocate h (Array_type T i) in
          if HA = {} then {(ε, execute.addr_of_sys_xcpt OutOfMemory, h, ((ins', ins, xt), stk, loc, C0, M0, pc) # frs)}
          else do { (h', a)  HA;
                {(NewHeapElem a (Array_type T i) , None, h', ((tl ins', ins, xt), Addr a # tl stk, loc, C0, M0, pc + 1) # frs)}})"
| "exec_instr ins' ins xt ALoad P t h stk loc C0 M0 pc frs =
   (let va = hd (tl stk)
    in (if va = Null then {(ε, execute.addr_of_sys_xcpt NullPointer, h, ((ins', ins, xt), stk, loc, C0, M0, pc) # frs)}
        else
          let i = the_Intg (hd stk);
              a = the_Addr va;
              len = alen_of_htype (the (typeof_addr h a))
          in if i <s 0  int len  sint i then
               {(ε, execute.addr_of_sys_xcpt ArrayIndexOutOfBounds, h, ((ins', ins, xt), stk, loc, C0, M0, pc) # frs)}
             else do {
               v  heap_read h a (ACell (nat (sint i)));
               {(ReadMem a (ACell (nat (sint i))) v, None, h, ((tl ins', ins, xt), v # tl (tl stk), loc, C0, M0, pc + 1) # frs)}
             }))"
| "exec_instr ins' ins xt AStore P t h stk loc C0 M0 pc frs =
  (let ve = hd stk;
       vi = hd (tl stk);
       va = hd (tl (tl stk))
   in (if va = Null then {(ε, execute.addr_of_sys_xcpt NullPointer, h, ((ins', ins, xt), stk, loc, C0, M0, pc) # frs)}
       else (let i = the_Intg vi;
                 idx = nat (sint i);
                 a = the_Addr va;
                 hT = the (typeof_addr h a);
                 T = ty_of_htype hT;
                 len = alen_of_htype hT;
                 U = the (execute.typeof_h h ve)
             in (if i <s 0  int len  sint i then
                      {(ε, execute.addr_of_sys_xcpt ArrayIndexOutOfBounds, h, ((ins', ins, xt), stk, loc, C0, M0, pc) # frs)}
                 else if P  U  the_Array T then 
                      do {
                         h'  heap_write h a (ACell idx) ve;
                         {(WriteMem a (ACell idx) ve, None, h', ((tl ins', ins, xt), tl (tl (tl stk)), loc, C0, M0, pc+1) # frs)}
                      }
                 else {(ε, (execute.addr_of_sys_xcpt ArrayStore, h, ((ins', ins, xt), stk, loc, C0, M0, pc) # frs))}))))"
| "exec_instr ins' ins xt ALength P t h stk loc C0 M0 pc frs =
   {(ε, (let va = hd stk
         in if va = Null
            then (execute.addr_of_sys_xcpt NullPointer, h, ((ins', ins, xt), stk, loc, C0, M0, pc) # frs)
            else (None, h, ((tl ins', ins, xt), Intg (word_of_int (int (alen_of_htype (the (typeof_addr h (the_Addr va)))))) # tl stk, loc, C0, M0, pc+1) # frs)))}"
| "exec_instr ins' ins xt (Getfield F C) P t h stk loc C0 M0 pc frs = 
   (let v = hd stk
    in if v = Null then {(ε, execute.addr_of_sys_xcpt NullPointer, h, ((ins', ins, xt), stk, loc, C0, M0, pc) # frs)}
       else let a = the_Addr v
            in do {
               v'  heap_read h a (CField C F);
               {(ReadMem a (CField C F) v', None, h, ((tl ins', ins, xt), v' # (tl stk), loc, C0, M0, pc + 1) # frs)}
            })"
| "exec_instr ins' ins xt (Putfield F C) P t h stk loc C0 M0 pc frs = 
  (let v = hd stk;
       r = hd (tl stk)
   in if r = Null then {(ε, execute.addr_of_sys_xcpt NullPointer, h, ((ins', ins, xt), stk, loc, C0, M0, pc) # frs)}
      else let a = the_Addr r
           in do {
                h'  heap_write h a (CField C F) v;
                {(WriteMem a (CField C F) v, None, h', ((tl ins', ins, xt), tl (tl stk), loc, C0, M0, pc + 1) # frs)}
              })"
| "exec_instr ins' ins xt (CAS F C) P t h stk loc C0 M0 pc frs =
  (let v'' = hd stk; v' = hd (tl stk); v = hd (tl (tl stk))
   in if v = Null then {(ε, execute.addr_of_sys_xcpt NullPointer, h, ((ins', ins, xt), stk, loc, C0, M0, pc) # frs)}
      else let a = the_Addr v
           in do {
               v'''  heap_read h a (CField C F);
               if v''' = v' then do {
                 h'  heap_write h a (CField C F) v'';
                 {(ReadMem a (CField C F) v', WriteMem a (CField C F) v'', None, h', ((tl ins', ins, xt), Bool True # tl (tl (tl stk)), loc, C0, M0, pc + 1) # frs)}
               } else {(ReadMem a (CField C F) v''', None, h, ((tl ins', ins, xt), Bool False # tl (tl (tl stk)), loc, C0, M0, pc + 1) # frs)}
             })"
| "exec_instr ins' ins xt (Checkcast T) P t h stk loc C0 M0 pc frs =
   {(ε, let U = the (typeofh (hd stk))
        in if P  U  T then (None, h, ((tl ins', ins, xt), stk, loc, C0, M0, pc + 1) # frs)
           else (execute.addr_of_sys_xcpt ClassCast, h, ((ins', ins, xt), stk, loc, C0, M0, pc) # frs))}"
| "exec_instr ins' ins xt (Instanceof T) P t h stk loc C0 M0 pc frs =
   {(ε, None, h, ((tl ins', ins, xt), Bool (hd stk  Null  P  the (typeofh (hd stk))  T) # tl stk, loc, C0, M0, pc + 1) # frs)}"
| "exec_instr ins' ins xt (Invoke M n) P t h stk loc C0 M0 pc frs =
   (let r = stk ! n
    in (if r = Null then {(ε, execute.addr_of_sys_xcpt NullPointer, h, ((ins', ins, xt), stk, loc, C0, M0, pc) # frs)}
        else (let ps = rev (take n stk);
                  a = the_Addr r;
                  T = the (typeof_addr h a);
                  (D,Ts,T,meth)= method P (class_type_of T) M
              in case meth of
                   Native  
                      do {
                        (ta, va, h')  red_external_aggr P t a M ps h;
                        {(extTA2JVM' P ta, extRet2JVM' ins' ins xt n h' stk loc C0 M0 pc frs va)}
                      }
                 | (mxs,mxl0,ins'',xt'') 
                       let f' = ((ins'', ins'', xt''), [],[r]@ps@(replicate mxl0 undefined_value),D,M,0)
                       in {(ε, None, h, f' # ((ins', ins, xt), stk, loc, C0, M0, pc) # frs)})))"
| "exec_instr ins' ins xt Return P t h stk0 loc0 C0 M0 pc frs =
   {(ε, (if frs=[] then (None, h, []) 
         else 
           let v = hd stk0; 
               ((ins', ins, xt), stk,loc,C,m,pc) = hd frs;
                n = length (fst (snd (method P C0 M0)))
           in (None, h, ((tl ins', ins, xt), v#(drop (n+1) stk),loc,C,m,pc+1)#tl frs)))}"
| "exec_instr ins' ins xt Pop P t h stk loc C0 M0 pc frs = 
   {(ε, (None, h, ((tl ins', ins, xt), tl stk, loc, C0, M0, pc+1)#frs))}"
| "exec_instr ins' ins xt Dup P t h stk loc C0 M0 pc frs =
   {(ε, (None, h, ((tl ins', ins, xt), hd stk # stk, loc, C0, M0, pc+1)#frs))}"
| "exec_instr ins' ins xt Swap P t h stk loc C0 M0 pc frs = 
   {(ε, (None, h, ((tl ins', ins, xt), hd (tl stk) # hd stk # tl (tl stk), loc, C0, M0, pc+1)#frs))}"
| "exec_instr ins' ins xt (BinOpInstr bop) P t h stk loc C0 M0 pc frs =
   {(ε, 
     case the (execute.binop bop (hd (tl stk)) (hd stk)) of
       Inl v  (None, h, ((tl ins', ins, xt), v # tl (tl stk), loc, C0, M0, pc + 1) # frs)
     | Inr a  (Some a, h, ((ins', ins, xt), stk, loc, C0, M0, pc) # frs))}"
| "exec_instr ins' ins xt (IfFalse i) P t h stk loc C0 M0 pc frs =
   {(ε, (let pc' = if hd stk = Bool False then nat(int pc+i) else pc+1
         in (None, h, ((drop pc' ins, ins, xt), tl stk, loc, C0, M0, pc')#frs)))}"
| "exec_instr ins' ins xt (Goto i) P t h stk loc C0 M0 pc frs = 
   {let pc' = nat(int pc+i) 
    in (ε, (None, h, ((drop pc' ins, ins, xt), stk, loc, C0, M0, pc')#frs))}"
| "exec_instr ins' ins xt ThrowExc P t h stk loc C0 M0 pc frs =
   {(ε, (let xp' = if hd stk = Null then execute.addr_of_sys_xcpt NullPointer else the_Addr(hd stk)
         in (xp', h, ((ins', ins, xt), stk, loc, C0, M0, pc)#frs)))}"
| "exec_instr ins' ins xt MEnter P t h stk loc C0 M0 pc frs =
   {let v = hd stk
    in if v = Null
       then (ε, execute.addr_of_sys_xcpt NullPointer, h, ((ins', ins, xt), stk, loc, C0, M0, pc) # frs)
       else (Lockthe_Addr v, SyncLock (the_Addr v), None, h, ((tl ins', ins, xt), tl stk, loc, C0, M0, pc + 1) # frs)}"
| "exec_instr ins' ins xt MExit P t h stk loc C0 M0 pc frs =
  (let v = hd stk
   in if v = Null
      then {(ε, execute.addr_of_sys_xcpt NullPointer, h, ((ins', ins, xt), stk, loc, C0, M0, pc)#frs)}
      else {(Unlockthe_Addr v, SyncUnlock (the_Addr v), None, h, ((tl ins', ins, xt), tl stk, loc, C0, M0, pc + 1) # frs),
            (UnlockFailthe_Addr v, execute.addr_of_sys_xcpt IllegalMonitorState, h, ((ins', ins, xt), stk, loc, C0, M0, pc) # frs)})"

fun exception_step :: "'addr jvm_prog  'addr  'heap  'addr frame'  'addr frame' list  ('addr, 'heap) jvm_state'"
where
  "exception_step P a h ((ins', ins, xt), stk, loc, C, M, pc) frs = 
   (case match_ex_table P (execute.cname_of h a) pc xt of
          None  (a, h, frs)
        | Some (pc', d)  (None, h, ((drop pc' ins, ins, xt), Addr a # drop (size stk - d) stk, loc, C, M, pc') # frs))"

fun exec :: "'addr jvm_prog  'thread_id  ('addr, 'heap) jvm_state'  ('addr, 'thread_id, 'heap) jvm_ta_state' set"
  where
  "exec P t (xcp, h, []) = {}"
| "exec P t (None, h, ((ins', ins, xt), stk, loc, C, M, pc) # frs) = 
   exec_instr ins' ins xt (hd ins') P t h stk loc C M pc frs"
| "exec P t (a, h, fr # frs) = {(ε, exception_step P a h fr frs)}"

definition exec_1 ::
  "'addr jvm_prog  'thread_id  ('addr, 'heap) jvm_state'
    (('addr, 'thread_id, 'heap) jvm_thread_action' × ('addr, 'heap) jvm_state') Predicate.pred"
where "exec_1 P t σ = pred_of_set (exec P t σ)"

lemma check_exec_instr_ok:
  assumes wf: "wf_prog wf_md P"
  and "execute.check_instr i P h stk loc C M pc (map frame_of_frame' frs)"
  and "P  C sees M:TsT = m in D"
  and "jvm_state'_ok P (None, h, ((ins', ins, xt), stk, loc, C, M, pc) # frs)"
  and "tas  exec_instr ins' ins xt i P t h stk loc C M pc frs"
  shows "jvm_ta_state'_ok P tas"
proof -
  note [simp] = drop_Suc drop_tl split_beta jvm_thread_action'_ok_def has_method_def
  note [split] = if_split_asm sum.split
  from assms show ?thesis
  proof(cases i)
    case Return
    thus ?thesis using assms by(cases frs) auto
  next
    case Invoke
    thus ?thesis using assms 
      apply(cases m)
      apply(auto simp add: extNTA2JVM'_def dest: sees_method_idemp execute.red_external_aggr_new_thread_sub_thread sub_Thread_sees_run[OF wf])
       apply(drule execute.red_external_aggr_new_thread_sub_thread, clarsimp, clarsimp, assumption, clarsimp)
       apply(drule sub_Thread_sees_run[OF wf], clarsimp)
       apply(fastforce dest: sees_method_idemp)
      apply(drule execute.red_external_aggr_new_thread_sub_thread, clarsimp, clarsimp, assumption, clarsimp)
      apply(drule sub_Thread_sees_run[OF wf], clarsimp)
      apply(fastforce dest: sees_method_idemp)
      done
  next
    case Goto thus ?thesis using assms
      by(cases "m") simp
  next
    case IfFalse thus ?thesis using assms
      by(cases "m") simp
  qed(auto)
qed

lemma check_exec_instr_complete:
  assumes wf: "wf_prog wf_md P"
  and "execute.check_instr i P h stk loc C M pc (map frame_of_frame' frs)"
  and "P  C sees M:TsT = m in D"
  and "jvm_state'_ok P (None, h, ((ins', ins, xt), stk, loc, C, M, pc) # frs)"
  and "tas  execute.exec_instr i P t h stk loc C M pc (map frame_of_frame' frs)"
  shows "jvm_ta_state'_of_jvm_ta_state P tas  exec_instr ins' ins xt i P t h stk loc C M pc frs"
proof -
  note [simp] =
    drop_Suc drop_tl split_beta jvm_thread_action'_ok_def jvm_thread_action'_of_jvm_thread_action_def has_method_def
    ta_upd_simps map_tl
  note [split] = if_split_asm sum.split
  from assms show ?thesis
  proof(cases i)
    case Return thus ?thesis using assms by(cases frs) auto
  next
    case Goto thus ?thesis using assms
      by(cases "m") simp
  next
    case IfFalse thus ?thesis using assms
      by(cases "m") simp
  next
    case Invoke thus ?thesis using assms
      apply(cases "m")
      apply(auto intro!: rev_bexI convert_new_thread_action_eqI simp add: extNTA2JVM'_def extNTA2JVM_def dest: execute.red_external_aggr_new_thread_sub_thread sub_Thread_sees_run[OF wf] sees_method_idemp)
       apply(drule execute.red_external_aggr_new_thread_sub_thread, clarsimp, clarsimp, assumption, clarsimp)
       apply(drule sub_Thread_sees_run[OF wf], clarsimp)
       apply(fastforce dest: sees_method_idemp)
      apply(drule execute.red_external_aggr_new_thread_sub_thread, clarsimp, clarsimp, assumption, clarsimp)
      apply(drule sub_Thread_sees_run[OF wf], clarsimp)
      apply(fastforce dest: sees_method_idemp)
      done
  qed(auto 4 4)
qed

lemma check_exec_instr_refine:
  assumes wf: "wf_prog wf_md P"
  and "execute.check_instr i P h stk loc C M pc (map frame_of_frame' frs)"
  and "P  C sees M:TsT = m in D"
  and "jvm_state'_ok P (None, h, ((ins', ins, xt), stk, loc, C, M, pc) # frs)"
  and "tas  exec_instr ins' ins xt i P t h stk loc C M pc frs"
  shows "tas  jvm_ta_state'_of_jvm_ta_state P ` execute.exec_instr i P t h stk loc C M pc (map frame_of_frame' frs)"
proof -
  note [simp] =
    drop_Suc drop_tl split_beta jvm_thread_action'_ok_def jvm_thread_action'_of_jvm_thread_action_def has_method_def
    ta_upd_simps map_tl o_def
  note [split] = if_split_asm sum.split
  from assms have "jvm_ta_state_of_jvm_ta_state' tas  execute.exec_instr i P t h stk loc C M pc (map frame_of_frame' frs)"
  proof (cases i)
    case Invoke thus ?thesis using assms
      by(fastforce simp add: extNTA2JVM'_def extNTA2JVM_def split_def extRet2JVM'_extRet2JVM[simplified])
  next
    case Return thus ?thesis using assms by(auto simp add: neq_Nil_conv)
  qed (auto cong del: image_cong_simp)
  also from assms have ok': "jvm_ta_state'_ok P tas" by(rule check_exec_instr_ok)
  hence "jvm_ta_state_of_jvm_ta_state' tas  execute.exec_instr i P t h stk loc C M pc (map frame_of_frame' frs) 
    tas  jvm_ta_state'_of_jvm_ta_state P ` execute.exec_instr i P t h stk loc C M pc (map frame_of_frame' frs)"
    by(rule jvm_ta_state'_ok_inverse)
  finally show ?thesis .
qed

lemma exception_step_ok:
  assumes "frame'_ok P fr" "fset frs. frame'_ok P f"
  shows "jvm_state'_ok P (exception_step P a h fr frs)"
  and "exception_step P a h fr frs = jvm_state'_of_jvm_state P (execute.exception_step P a h (snd fr) (map frame_of_frame' frs))"
using assms
by(cases fr, case_tac "the (snd (snd (snd (method P d e))))", clarsimp)+

lemma exec_step_conv:
  assumes "wf_prog wf_md P"
  and "jvm_state'_ok P s"
  and "execute.check P (jvm_state_of_jvm_state' s)"
  shows "exec P t s = jvm_ta_state'_of_jvm_ta_state P ` execute.exec P t (jvm_state_of_jvm_state' s)"
using assms
apply(cases s)
apply(rename_tac xcp h frs)
apply(case_tac frs)
 apply(simp)
apply(case_tac xcp)
 prefer 2
 apply(simp add: jvm_thread_action'_of_jvm_thread_action_def exception_step_ok)
apply(clarsimp simp add: execute.check_def)
apply(rule equalityI)
 apply(clarsimp simp add: has_method_def)
 apply(erule (2) check_exec_instr_refine)
  apply fastforce
 apply(simp add: hd_drop_conv_nth)
apply(clarsimp simp add: has_method_def)
apply(drule (2) check_exec_instr_complete)
  apply fastforce
 apply(assumption)
apply(simp add: hd_drop_conv_nth)
done

lemma exec_step_ok:
  assumes "wf_prog wf_md P"
  and "jvm_state'_ok P s"
  and "execute.check P (jvm_state_of_jvm_state' s)"
  and "tas  exec P t s"
  shows "jvm_ta_state'_ok P tas"
using assms
apply(cases s)
apply(rename_tac xcp h frs)
apply(case_tac frs)
 apply simp
apply(rename_tac fr frs')
apply(case_tac xcp)
 apply(clarsimp simp add: execute.check_def has_method_def)
 apply(erule (2) check_exec_instr_ok)
  apply fastforce
 apply(simp add: hd_drop_conv_nth)
apply(case_tac fr)
apply(rename_tac cache stk loc C M pc)
apply(case_tac "the (snd (snd (snd (method P C M))))")
apply auto
done

end


locale JVM_heap_execute_conf_read = JVM_heap_execute +
  execute: JVM_conf_read
    addr2thread_id thread_id2addr 
    spurious_wakeups
    empty_heap allocate typeof_addr 
    "λh a ad v. v  heap_read h a ad" "λh a ad v h'. h'  heap_write h a ad v"
  +
  constrains addr2thread_id :: "('addr :: addr)  'thread_id" 
  and thread_id2addr :: "'thread_id  'addr" 
  and spurious_wakeups :: bool
  and empty_heap :: "'heap" 
  and allocate :: "'heap  htype  ('heap × 'addr) set" 
  and typeof_addr :: "'heap  'addr  htype option" 
  and heap_read :: "'heap  'addr  addr_loc  'addr val set" 
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap set"
  and hconf :: "'heap  bool"
  and P :: "'addr jvm_prog"
begin

lemma exec_correct_state:
  assumes wt: "wf_jvm_progΦ P"
  and correct: "execute.correct_state Φ t (jvm_state_of_jvm_state' s)"
  and ok: "jvm_state'_ok P s"
  shows "exec P t s = jvm_ta_state'_of_jvm_ta_state P ` execute.exec P t (jvm_state_of_jvm_state' s)"
  (is ?thesis1)
  and "(ta, s')  exec P t s  execute.correct_state Φ t (jvm_state_of_jvm_state' s')" (is "_  ?thesis2")
  and "tas  exec P t s  jvm_ta_state'_ok P tas"
proof -
  from wt obtain wf_md where wf: "wf_prog wf_md P" by(blast dest: wt_jvm_progD)
  from execute.no_type_error[OF wt correct]
  have check: "execute.check P (jvm_state_of_jvm_state' s)"
    by(simp add: execute.exec_d_def split: if_split_asm)
  with wf ok show eq: ?thesis1 by(rule exec_step_conv)

  { fix tas
    assume "tas  exec P t s"
    with wf ok check show "jvm_ta_state'_ok P tas"
      by(rule exec_step_ok) }
  note this[of "(ta, s')"]
  moreover
  assume "(ta, s')  exec P t s"
  moreover
  hence "(ta, s')  jvm_ta_state'_of_jvm_ta_state P ` execute.exec P t (jvm_state_of_jvm_state' s)"
    unfolding eq by simp
  ultimately have "jvm_ta_state_of_jvm_ta_state' (ta, s')  execute.exec P t (jvm_state_of_jvm_state' s)"
    using jvm_ta_state'_ok_inverse[of P "(ta, s')"] by blast
  hence "execute.exec_1 P t (jvm_state_of_jvm_state' s) (jvm_thread_action_of_jvm_thread_action' ta) (jvm_state_of_jvm_state' s')"
    by(simp add: execute.exec_1_iff)
  with wt correct show ?thesis2 by(rule execute.BV_correct_1)
qed

end

lemmas [code] = 
  JVM_heap_execute.exec_instr.simps
  JVM_heap_execute.exception_step.simps
  JVM_heap_execute.exec.simps
  JVM_heap_execute.exec_1_def

end

Theory JVM_Execute2

(*  Title:      JinjaThreads/Execute/JVM_Execute2.thy
    Author:     Andreas Lochbihler
*)

theory JVM_Execute2
imports
  SC_Schedulers
  JVMExec_Execute2
  "../BV/BVProgressThreaded"
begin

abbreviation sc_heap_read_cset :: "heap  addr  addr_loc  addr val set"
where "sc_heap_read_cset h ad al  set_of_pred (sc_heap_read_i_i_i_o h ad al)"

abbreviation sc_heap_write_cset :: "heap  addr  addr_loc  addr val  heap set"
where "sc_heap_write_cset h ad al v  set_of_pred (sc_heap_write_i_i_i_i_o h ad al v)"

interpretation sc: 
  JVM_heap_execute
    "addr2thread_id"
    "thread_id2addr"
    "sc_spurious_wakeups"
    "sc_empty"
    "sc_allocate P"
    "sc_typeof_addr"
    "sc_heap_read_cset"
    "sc_heap_write_cset"
  rewrites "h ad al v. v  sc_heap_read_cset h ad al  sc_heap_read h ad al v"
  and "h ad al v h'. h'  sc_heap_write_cset h ad al v  sc_heap_write h ad al v h'"
  for P
apply(simp_all add: eval_sc_heap_read_i_i_i_o eval_sc_heap_write_i_i_i_i_o)
done

interpretation sc: 
  JVM_heap_execute_conf_read
    "addr2thread_id"
    "thread_id2addr"
    "sc_spurious_wakeups"
    "sc_empty"
    "sc_allocate P"
    "sc_typeof_addr"
    "sc_heap_read_cset"
    "sc_heap_write_cset"
    "sc_hconf P"
    "P"
  rewrites "h ad al v. v  sc_heap_read_cset h ad al  sc_heap_read h ad al v"
  and "h ad al v h'. h'  sc_heap_write_cset h ad al v  sc_heap_write h ad al v h'"
  for P
proof -
  show unfolds: "h ad al v. v  sc_heap_read_cset h ad al  sc_heap_read h ad al v"
    "h ad al v h'. h'  sc_heap_write_cset h ad al v  sc_heap_write h ad al v h'"
    by(simp_all add: eval_sc_heap_read_i_i_i_o eval_sc_heap_write_i_i_i_i_o)
  show "JVM_heap_execute_conf_read
    addr2thread_id thread_id2addr
    sc_empty (sc_allocate P)
    sc_typeof_addr sc_heap_read_cset sc_heap_write_cset
    (sc_hconf P) P"
    apply(rule JVM_heap_execute_conf_read.intro)
    apply(unfold unfolds)
    apply(unfold_locales)
    done
qed

abbreviation sc_JVM_start_state :: "addr jvm_prog  cname  mname  addr val list  (addr,thread_id,addr jvm_thread_state,heap,addr) state"
where "sc_JVM_start_state P  sc.execute.JVM_start_state TYPE(addr jvm_method) P P"

abbreviation sc_exec :: "addr jvm_prog  thread_id  (addr, heap) jvm_state'  (addr, thread_id, heap) jvm_ta_state' set"
where "sc_exec P  sc.exec TYPE(addr jvm_method) P P"

abbreviation sc_execute_mexec :: "addr jvm_prog  thread_id  (addr jvm_thread_state × heap)
   (addr, thread_id, heap) jvm_thread_action  (addr jvm_thread_state × heap)  bool"
where "sc_execute_mexec P  sc.execute.mexec TYPE(addr jvm_method) P P"

fun sc_mexec :: 
  "addr jvm_prog  thread_id  (addr jvm_thread_state' × heap) 
   ((addr, thread_id, heap) jvm_thread_action' × addr jvm_thread_state' × heap) Predicate.pred"
where 
  "sc_mexec P t ((xcp, frs), h) =
   sc.exec_1 (TYPE(addr jvm_method)) P P t (xcp, h, frs)  (λ(ta, xcp, h, frs). Predicate.single (ta, (xcp, frs), h))"

abbreviation sc_jvm_start_state_refine :: 
  "addr jvm_prog  cname  mname  addr val list  
  (addr, thread_id, heap, (thread_id, (addr jvm_thread_state') × addr released_locks) rbt, (thread_id, addr wait_set_status) rbt, thread_id rs) state_refine"
where
  "sc_jvm_start_state_refine  
   sc_start_state_refine (rm_empty ()) rm_update (rm_empty ()) (rs_empty ()) (λC M Ts T (mxs, mxl0, ins, xt) vs. (None, [((ins, ins, xt), [], Null # vs @ replicate mxl0 undefined_value, C, M, 0)]))"

fun jvm_mstate_of_jvm_mstate' :: 
  "(addr,thread_id,addr jvm_thread_state',heap,addr) state  (addr,thread_id,addr jvm_thread_state,heap,addr) state"
where
  "jvm_mstate_of_jvm_mstate' (ls, (ts, m), ws) = (ls, (λt. map_option (map_prod jvm_thread_state_of_jvm_thread_state' id) (ts t), m), ws)"

definition sc_jvm_state_invar :: "addr jvm_prog  tyP  (addr,thread_id,addr jvm_thread_state',heap,addr) state set"
where
  "sc_jvm_state_invar P Φ  
   {s. jvm_mstate_of_jvm_mstate' s  sc.execute.correct_jvm_state P Φ}  
   {s. ts_ok (λt (xcp, frs) h. jvm_state'_ok P (xcp, h, frs)) (thr s) (shr s)}"

fun JVM_final' :: "'addr jvm_thread_state'  bool"
where "JVM_final' (xcp, frs)  frs = []"

lemma shr_jvm_mstate_of_jvm_mstate' [simp]: "shr (jvm_mstate_of_jvm_mstate' s) = shr s"
by(cases s) clarsimp

lemma jvm_mstate_of_jvm_mstate'_sc_start_state [simp]:
  "jvm_mstate_of_jvm_mstate'
  (sc_start_state (λC M Ts T (mxs, mxl0, ins, xt) vs. (None, [((ins, ins, xt), [], Null # vs @ replicate mxl0 undefined_value, C, M, 0)])) P C M vs) = sc_JVM_start_state P C M vs"
by(simp add: sc.start_state_def split_beta fun_eq_iff)

lemma sc_jvm_start_state_invar:
  assumes "wf_jvm_progΦ P"
  and "sc_wf_start_state P C M vs"
  shows "sc_state_α (sc_jvm_start_state_refine P C M vs)  sc_jvm_state_invar P Φ"
unfolding sc_jvm_state_invar_def Int_iff mem_Collect_eq
apply(rule conjI)
 apply(simp add: sc.execute.correct_jvm_state_initial[OF assms])
apply(rule ts_okI)
using ‹sc_wf_start_state P C M vs
apply(auto simp add: sc.start_state_def split_beta sc_wf_start_state_iff split: if_split_asm dest: sees_method_idemp)
done

lemma invariant3p_sc_jvm_state_invar:
  assumes "wf_jvm_progΦ P"
  shows "invariant3p (multithreaded_base.redT JVM_final' (λt xm ta x'm'. Predicate.eval (sc_mexec P t xm) (ta, x'm')) convert_RA) (sc_jvm_state_invar P Φ)"
proof(rule invariant3pI)
  fix s tl s'
  assume red: "multithreaded_base.redT JVM_final' (λt xm ta x'm'. Predicate.eval (sc_mexec P t xm) (ta, x'm')) convert_RA s tl s'"
    and invar: "s  sc_jvm_state_invar P Φ"
  obtain t ta where tl: "tl = (t, ta)" by(cases tl)
  from red have red': "multithreaded_base.redT JVM_final (sc_execute_mexec P) convert_RA (jvm_mstate_of_jvm_mstate' s) (t, jvm_thread_action_of_jvm_thread_action' ta) (jvm_mstate_of_jvm_mstate' s')"
  proof(cases rule: multithreaded_base.redT.cases[consumes 1, case_names normal acquire])
    case (acquire s t x ln n s')
    thus ?thesis using tl by(cases s)(auto intro!: multithreaded_base.redT.redT_acquire)
  next
    case (normal t x s ta x' m' s')
    obtain xcp frs where x: "x = (xcp, frs)" by(cases x)
    with invar normal tl
    have correct: "sc.execute.correct_state P Φ t (jvm_state_of_jvm_state' (xcp, shr s, frs))"
      and ok: "jvm_state'_ok P (xcp, shr s, frs)"
      apply -
      apply(case_tac [!] s)
      apply(fastforce simp add: sc_jvm_state_invar_def sc.execute.correct_jvm_state_def dest: ts_okD)+
      done
    note eq = sc.exec_correct_state(1)[OF assms this]
    with normal x tl
    have "sc_execute_mexec P t (jvm_thread_state_of_jvm_thread_state' x, shr (jvm_mstate_of_jvm_mstate' s)) (jvm_thread_action_of_jvm_thread_action' ta) (jvm_thread_state_of_jvm_thread_state' x', m')" 
      by(auto simp add: sc.exec_1_def eq jvm_thread_action'_of_jvm_thread_action_def sc.execute.exec_1_iff)
    with normal tl show ?thesis
      by(cases s)(fastforce intro!: multithreaded_base.redT.redT_normal simp add: final_thread.actions_ok_iff fun_eq_iff map_redT_updTs elim: rev_iffD1[OF _ thread_oks_ts_change] cond_action_oks_final_change)
  qed
  moreover from invar
  have "sc.execute.correct_state_ts P Φ (thr (jvm_mstate_of_jvm_mstate' s)) (shr (jvm_mstate_of_jvm_mstate' s))"
    and "lock_thread_ok (locks (jvm_mstate_of_jvm_mstate' s)) (thr (jvm_mstate_of_jvm_mstate' s))"
    by(simp_all add: sc_jvm_state_invar_def sc.execute.correct_jvm_state_def)
  ultimately have "sc.execute.correct_state_ts P Φ (thr (jvm_mstate_of_jvm_mstate' s')) (shr (jvm_mstate_of_jvm_mstate' s'))"
    and "lock_thread_ok (locks (jvm_mstate_of_jvm_mstate' s')) (thr (jvm_mstate_of_jvm_mstate' s'))"
    by(blast intro: lifting_wf.redT_preserves[OF sc.execute.lifting_wf_correct_state, OF assms] sc.execute.exec_mthr.redT_preserves_lock_thread_ok)+
  hence "jvm_mstate_of_jvm_mstate' s'  sc.execute.correct_jvm_state P Φ"
    by(simp add: sc.execute.correct_jvm_state_def)
  moreover from red have "ts_ok (λt (xcp, frs) h. fset frs. frame'_ok P f) (thr s') (shr s')" unfolding tl 
  proof(cases rule: multithreaded_base.redT.cases[consumes 1, case_names normal acquire])
    case acquire thus ?thesis using invar
      by(fastforce simp add: sc_jvm_state_invar_def intro!: ts_okI dest: ts_okD bspec split: if_split_asm)
  next
    case (normal t x s ta x' m' s')
    obtain xcp frs where x: "x = (xcp, frs)" by(cases x)
    with invar normal tl
    have correct: "sc.execute.correct_state P Φ t (jvm_state_of_jvm_state' (xcp, shr s, frs))"
      and ok: "jvm_state'_ok P (xcp, shr s, frs)"
      apply -
      apply(case_tac [!] s)
      apply(fastforce simp add: sc_jvm_state_invar_def sc.execute.correct_jvm_state_def dest: ts_okD)+
      done
    from normal x invar show ?thesis
      apply(auto simp add: sc.exec_1_def final_thread.actions_ok_iff jvm_thread_action'_ok_def sc_jvm_state_invar_def)
      apply hypsubst_thin
      apply(drule sc.exec_correct_state(3)[OF assms correct ok])
      apply(rule ts_okI)
      apply(clarsimp split: if_split_asm simp add: jvm_thread_action'_ok_def)
      apply(drule (1) bspec)
      apply simp
      apply(case_tac "thr s t")
       apply(drule (2) redT_updTs_new_thread)
       apply clarsimp
       apply(drule (1) bspec)
       apply simp
       apply(drule (1) bspec)
       apply simp
      apply(erule thin_rl)
      apply(frule (1) redT_updTs_Some)
      apply(fastforce dest: ts_okD)
      done
  qed
  ultimately show "s'  sc_jvm_state_invar P Φ" by(simp add: sc_jvm_state_invar_def)
qed

lemma sc_exec_deterministic:
  assumes "wf_jvm_progΦ P"
  shows "multithreaded_base.deterministic JVM_final' (λt xm ta x'm'. Predicate.eval (sc_mexec P t xm) (ta, x'm')) convert_RA
     (sc_jvm_state_invar P Φ)"
proof -
  from assms sc_deterministic_heap_ops
  have det: "multithreaded_base.deterministic JVM_final (sc_execute_mexec P) convert_RA {s. sc.execute.correct_state_ts P Φ (thr s) (shr s)}"
    by(rule sc.execute.mexec_deterministic)(simp add: sc_spurious_wakeups)
  show ?thesis
  proof(rule multithreaded_base.determisticI)
    fix s t x ta' x' m' ta'' x'' m''
    assume inv: "s  sc_jvm_state_invar P Φ"
      and tst: "thr s t = (x, no_wait_locks)"
      and exec1: "Predicate.eval (sc_mexec P t (x, shr s)) (ta', x', m')"
      and exec2: "Predicate.eval (sc_mexec P t (x, shr s)) (ta'', x'', m'')"
      and aok1: "final_thread.actions_ok JVM_final' s t ta'"
      and aok2: "final_thread.actions_ok JVM_final' s t ta''"
    obtain xcp frs where x: "x = (xcp, frs)" by(cases x)
    from inv tst x have correct: "sc.execute.correct_state P Φ t (jvm_state_of_jvm_state' (xcp, shr s, frs))"
      and ok: "jvm_state'_ok P (xcp, shr s, frs)"
      by(cases s, fastforce simp add: sc_jvm_state_invar_def sc.execute.correct_jvm_state_def dest: ts_okD)+
    note eq = sc.exec_correct_state(1)[OF assms this]
    
    from exec1 exec2 x
    have "sc_execute_mexec P t (jvm_thread_state_of_jvm_thread_state' x, shr (jvm_mstate_of_jvm_mstate' s)) (jvm_thread_action_of_jvm_thread_action' ta') (jvm_thread_state_of_jvm_thread_state' x', m')" 
      and "sc_execute_mexec P t (jvm_thread_state_of_jvm_thread_state' x, shr (jvm_mstate_of_jvm_mstate' s)) (jvm_thread_action_of_jvm_thread_action' ta'') (jvm_thread_state_of_jvm_thread_state' x'', m'')"
      by(auto simp add: sc.exec_1_def eq jvm_thread_action'_of_jvm_thread_action_def sc.execute.exec_1_iff)
    moreover have "thr (jvm_mstate_of_jvm_mstate' s) t = (jvm_thread_state_of_jvm_thread_state' x, no_wait_locks)"
      using tst by(cases s) clarsimp
    moreover have "final_thread.actions_ok JVM_final (jvm_mstate_of_jvm_mstate' s) t (jvm_thread_action_of_jvm_thread_action' ta')"
      and "final_thread.actions_ok JVM_final (jvm_mstate_of_jvm_mstate' s) t (jvm_thread_action_of_jvm_thread_action' ta'')"
      using aok1 aok2
      by -(case_tac [!] s,auto simp add: final_thread.actions_ok_iff elim: rev_iffD1[OF _ thread_oks_ts_change] cond_action_oks_final_change)
    moreover have "sc.execute.correct_state_ts P Φ (thr (jvm_mstate_of_jvm_mstate' s)) (shr (jvm_mstate_of_jvm_mstate' s))"
      using inv
      by(cases s)(auto intro!: ts_okI simp add: sc_jvm_state_invar_def sc.execute.correct_jvm_state_def dest: ts_okD)
    ultimately
    have "jvm_thread_action_of_jvm_thread_action' ta' = jvm_thread_action_of_jvm_thread_action' ta'' 
          jvm_thread_state_of_jvm_thread_state' x' = jvm_thread_state_of_jvm_thread_state' x'' 
          m' = m''"
      by-(drule (4) multithreaded_base.deterministicD[OF det], simp_all)
    moreover from exec1 exec2 x
    have "(ta', (fst x', m', snd x'))  sc_exec P t (xcp, shr s, frs)" 
      and "(ta'', (fst x'', m'', snd x''))  sc_exec P t (xcp, shr s, frs)"
      by(auto simp add: sc.exec_1_def)
    hence "jvm_ta_state'_ok P (ta', (fst x', m', snd x'))"
      and "jvm_ta_state'_ok P (ta'', (fst x'', m'', snd x''))"
      by(blast intro: sc.exec_correct_state[OF assms correct ok])+
    hence "ta' = jvm_thread_action'_of_jvm_thread_action P (jvm_thread_action_of_jvm_thread_action' ta')"
      and "ta'' = jvm_thread_action'_of_jvm_thread_action P (jvm_thread_action_of_jvm_thread_action' ta'')"
      and "x' = jvm_thread_state'_of_jvm_thread_state P (jvm_thread_state_of_jvm_thread_state' x')"
      and "x'' = jvm_thread_state'_of_jvm_thread_state P (jvm_thread_state_of_jvm_thread_state' x'')"
      apply -
      apply(case_tac [!] ta')
      apply(case_tac [!] ta'')
      apply(case_tac [!] x')
      apply(case_tac [!] x'')
      apply(fastforce simp add: jvm_thread_action'_of_jvm_thread_action_def jvm_thread_action'_ok_def intro!: map_idI[symmetric] convert_new_thread_action_eqI dest: bspec)+
      done
    ultimately
    show "ta' = ta''  x' = x''  m' = m''" by simp
  qed(rule invariant3p_sc_jvm_state_invar[OF assms])
qed

subsection ‹Round-robin scheduler›

interpretation JVM_rr: 
  sc_round_robin_base
    JVM_final' "sc_mexec P" convert_RA Jinja_output
  for P
.

definition sc_rr_JVM_start_state :: "nat  'm prog  thread_id fifo round_robin"
where "sc_rr_JVM_start_state n0 P = JVM_rr.round_robin_start n0 (sc_start_tid P)"

definition exec_JVM_rr ::
  "nat  addr jvm_prog  cname  mname  addr val list  
  (thread_id × (addr, thread_id) obs_event list, 
   (addr, thread_id) locks × ((thread_id, addr jvm_thread_state' × addr released_locks) RBT.rbt × heap) ×
   (thread_id, addr wait_set_status) RBT.rbt × thread_id rs) tllist"
where
  "exec_JVM_rr n0 P C M vs = JVM_rr.exec P n0 (sc_rr_JVM_start_state n0 P) (sc_jvm_start_state_refine P C M vs)"

interpretation JVM_rr:
  sc_round_robin 
    JVM_final' "sc_mexec P" convert_RA Jinja_output
  for P
by(unfold_locales)

lemma JVM_rr:
  assumes "wf_jvm_progΦ P"
  shows
  "sc_scheduler 
     JVM_final' (sc_mexec P) convert_RA
     (JVM_rr.round_robin P n0) (pick_wakeup_via_sel (λs P. rm_sel s (λ(k,v). P k v))) JVM_rr.round_robin_invar
     (sc_jvm_state_invar P Φ)"
unfolding sc_scheduler_def
apply(rule JVM_rr.round_robin_scheduler)
apply(rule sc_exec_deterministic[OF assms])
done

subsection ‹Random scheduler›

interpretation JVM_rnd: 
  sc_random_scheduler_base
    JVM_final' "sc_mexec P" convert_RA Jinja_output
  for P
.

definition sc_rnd_JVM_start_state :: "Random.seed  random_scheduler"
where "sc_rnd_JVM_start_state seed = seed"

definition exec_JVM_rnd ::
  "Random.seed  addr jvm_prog  cname  mname  addr val list  
  (thread_id × (addr, thread_id) obs_event list,
   (addr, thread_id) locks × ((thread_id, addr jvm_thread_state' × addr released_locks) RBT.rbt × heap) ×
   (thread_id, addr wait_set_status) RBT.rbt × thread_id rs) tllist"
where "exec_JVM_rnd seed P C M vs = JVM_rnd.exec P (sc_rnd_JVM_start_state seed) (sc_jvm_start_state_refine P C M vs)"

interpretation JVM_rnd:
  sc_random_scheduler
    JVM_final' "sc_mexec P" convert_RA Jinja_output
  for P
by(unfold_locales)

lemma JVM_rnd:
  assumes "wf_jvm_progΦ P"
  shows 
  "sc_scheduler
    JVM_final' (sc_mexec P) convert_RA
    (JVM_rnd.random_scheduler P) (pick_wakeup_via_sel (λs P. rm_sel s (λ(k,v). P k v))) (λ_ _. True)
    (sc_jvm_state_invar P Φ)"
unfolding sc_scheduler_def
apply(rule JVM_rnd.random_scheduler_scheduler)
apply(rule sc_exec_deterministic[OF assms])
done

ML_val @{code exec_JVM_rr}

ML_val @{code exec_JVM_rnd}

end

Theory Code_Generation

(*  Title:      JinjaThreads/Execute/Code_Generation.thy
    Author:     Andreas Lochbihler
*)

section ‹Code generator setup›

theory Code_Generation 
imports
  J_Execute
  JVM_Execute2 
  "../Compiler/Preprocessor"
  "../BV/BCVExec"
  "../Compiler/Compiler"
  Coinductive.Lazy_TLList
  "HOL-Library.Code_Target_Int"
  "HOL-Library.Code_Target_Numeral"
begin

text ‹Avoid module dependency cycles.›
(* FIXME: Eliminate dependency cycle in Isabelle library *) 

code_identifier
  code_module More_Set  (SML) Set
| code_module Set  (SML) Set
| code_module Complete_Lattices  (SML) Set
| code_module Complete_Partial_Order  (SML) Set

text ‹new code equation for @{term "insort_insert_key"} to avoid module dependency cycle with @{term "set"}.›
lemma insort_insert_key_code [code]:
  "insort_insert_key f x xs = 
  (if List.member (map f xs) (f x) then xs else insort_key f x xs)"
by(simp add: insort_insert_key_def List.member_def split del: if_split)


text ‹equations on predicate operations for code inlining›

lemma eq_i_o_conv_single: "eq_i_o = Predicate.single"
by(rule ext)(simp add: Predicate.single_bind eq.equation)

lemma eq_o_i_conv_single: "eq_o_i = Predicate.single"
by(rule ext)(simp add: Predicate.single_bind eq.equation)

lemma sup_case_exp_case_exp_same:
  "sup_class.sup 
    (case_exp cNew cNewArray cCast cInstanceOf cVal cBinOp cVar cLAss cAAcc cAAss cALen cFAcc cFAss cCAS cCall cBlock cSync cInSync cSeq cCond cWhile cThrow cTry e)
    (case_exp cNew' cNewArray' cCast' cInstanceOf' cVal' cBinOp' cVar' cLAss' cAAcc' cAAss' cALen' cFAcc' cFAss' cCAS' cCall' cBlock' cSync' cInSync' cSeq' cCond' cWhile' cThrow' cTry' e) =
  (case e of
    new C  sup_class.sup (cNew C) (cNew' C)
  | newArray T e  sup_class.sup (cNewArray T e) (cNewArray' T e)
  | Cast T e  sup_class.sup (cCast T e) (cCast' T e)
  | InstanceOf e T  sup_class.sup (cInstanceOf e T) (cInstanceOf' e T)
  | Val v  sup_class.sup (cVal v) (cVal' v)
  | BinOp e bop e'  sup_class.sup (cBinOp e bop e') (cBinOp' e bop e')
  | Var V  sup_class.sup (cVar V) (cVar' V)
  | LAss V e  sup_class.sup (cLAss V e) (cLAss' V e)
  | AAcc a e  sup_class.sup (cAAcc a e) (cAAcc' a e)
  | AAss a i e  sup_class.sup (cAAss a i e) (cAAss' a i e)
  | ALen a  sup_class.sup (cALen a) (cALen' a)
  | FAcc e F D  sup_class.sup (cFAcc e F D) (cFAcc' e F D)
  | FAss e F D e'  sup_class.sup (cFAss e F D e') (cFAss' e F D e')
  | CompareAndSwap e D F e' e''  sup_class.sup (cCAS e D F e' e'') (cCAS' e D F e' e'')
  | Call e M es  sup_class.sup (cCall e M es) (cCall' e M es)
  | Block V T vo e  sup_class.sup (cBlock V T vo e) (cBlock' V T vo e)
  | Synchronized v e e'  sup_class.sup (cSync v e e') (cSync' v e e')
  | InSynchronized v a e  sup_class.sup (cInSync v a e) (cInSync' v a e)
  | Seq e e'  sup_class.sup (cSeq e e') (cSeq' e e')
  | Cond b e e'  sup_class.sup (cCond b e e') (cCond' b e e')
  | While b e  sup_class.sup (cWhile b e) (cWhile' b e)
  | throw e  sup_class.sup (cThrow e) (cThrow' e)
  | TryCatch e C V e'  sup_class.sup (cTry e C V e') (cTry' e C V e'))"
apply(cases e)
apply(simp_all)
done

lemma sup_case_exp_case_exp_other:
  fixes p :: "'a :: semilattice_sup" shows
  "sup_class.sup 
    (case_exp cNew cNewArray cCast cInstanceOf cVal cBinOp cVar cLAss cAAcc cAAss cALen cFAcc cFAss cCAS cCall cBlock cSync cInSync cSeq cCond cWhile cThrow cTry e)
    (sup_class.sup (case_exp cNew' cNewArray' cCast' cInstanceOf' cVal' cBinOp' cVar' cLAss' cAAcc' cAAss' cALen' cFAcc' cFAss' cCAS' cCall' cBlock' cSync' cInSync' cSeq' cCond' cWhile' cThrow' cTry' e) p) =
  sup_class.sup (case e of
    new C  sup_class.sup (cNew C) (cNew' C)
  | newArray T e  sup_class.sup (cNewArray T e) (cNewArray' T e)
  | Cast T e  sup_class.sup (cCast T e) (cCast' T e)
  | InstanceOf e T  sup_class.sup (cInstanceOf e T) (cInstanceOf' e T)
  | Val v  sup_class.sup (cVal v) (cVal' v)
  | BinOp e bop e'  sup_class.sup (cBinOp e bop e') (cBinOp' e bop e')
  | Var V  sup_class.sup (cVar V) (cVar' V)
  | LAss V e  sup_class.sup (cLAss V e) (cLAss' V e)
  | AAcc a e  sup_class.sup (cAAcc a e) (cAAcc' a e)
  | AAss a i e  sup_class.sup (cAAss a i e) (cAAss' a i e)
  | ALen a  sup_class.sup (cALen a) (cALen' a)
  | FAcc e F D  sup_class.sup (cFAcc e F D) (cFAcc' e F D)
  | FAss e F D e'  sup_class.sup (cFAss e F D e') (cFAss' e F D e')
  | CompareAndSwap e D F e' e''  sup_class.sup (cCAS e D F e' e'') (cCAS' e D F e' e'')
  | Call e M es  sup_class.sup (cCall e M es) (cCall' e M es)
  | Block V T vo e  sup_class.sup (cBlock V T vo e) (cBlock' V T vo e)
  | Synchronized v e e'  sup_class.sup (cSync v e e') (cSync' v e e')
  | InSynchronized v a e  sup_class.sup (cInSync v a e) (cInSync' v a e)
  | Seq e e'  sup_class.sup (cSeq e e') (cSeq' e e')
  | Cond b e e'  sup_class.sup (cCond b e e') (cCond' b e e')
  | While b e  sup_class.sup (cWhile b e) (cWhile' b e)
  | throw e  sup_class.sup (cThrow e) (cThrow' e)
  | TryCatch e C V e'  sup_class.sup (cTry e C V e') (cTry' e C V e')) p"
apply(cases e)
apply(simp_all add: inf_sup_aci sup.assoc)
done

lemma sup_bot1: "sup_class.sup bot a = (a :: 'a :: {semilattice_sup, order_bot})"
by(rule sup_absorb2)auto

lemma sup_bot2: "sup_class.sup a bot = (a :: 'a :: {semilattice_sup, order_bot})"
by(rule sup_absorb1) auto

lemma sup_case_val_case_val_same:
  "sup_class.sup (case_val cUnit cNull cBool cIntg cAddr v) (case_val cUnit' cNull' cBool' cIntg' cAddr' v) =
   (case v of
     Unit  sup_class.sup cUnit cUnit'
   | Null  sup_class.sup cNull cNull'
   | Bool b  sup_class.sup (cBool b) (cBool' b)
   | Intg i  sup_class.sup (cIntg i) (cIntg' i)
   | Addr a  sup_class.sup (cAddr a) (cAddr' a))"
apply(cases v)
apply simp_all
done

lemma sup_case_bool_case_bool_same:
  "sup_class.sup (case_bool t f b) (case_bool t' f' b) =
  (if b then sup_class.sup t t' else sup_class.sup f f')"
by simp

lemmas predicate_code_inline [code_unfold] =
  Predicate.single_bind Predicate.bind_single split
  eq_i_o_conv_single eq_o_i_conv_single
  sup_case_exp_case_exp_same sup_case_exp_case_exp_other unit.case
  sup_bot1 sup_bot2 sup_case_val_case_val_same sup_case_bool_case_bool_same

lemma op_case_ty_case_ty_same:
  "f (case_ty cVoid cBoolean cInteger cNT cClass cArray e)
     (case_ty cVoid' cBoolean' cInteger' cNT' cClass' cArray' e) =
  (case e of
     Void  f cVoid cVoid'
   | Boolean  f cBoolean cBoolean'
   | Integer  f cInteger cInteger'
   | NT  f cNT cNT'
   | Class C  f (cClass C) (cClass' C)
   | Array T  f (cArray T) (cArray' T))"
by(simp split: ty.split)

declare op_case_ty_case_ty_same[where f="sup_class.sup", code_unfold]

lemma op_case_bop_case_bop_same:
  "f (case_bop cEq cNotEq cLessThan cLessOrEqual cGreaterThan cGreaterOrEqual cAdd cSubtract cMult cDiv cMod cBinAnd cBinOr cBinXor cShiftLeft cShiftRightZeros cShiftRightSigned bop)
     (case_bop cEq' cNotEq' cLessThan' cLessOrEqual' cGreaterThan' cGreaterOrEqual' cAdd' cSubtract' cMult' cDiv' cMod' cBinAnd' cBinOr' cBinXor' cShiftLeft' cShiftRightZeros' cShiftRightSigned' bop)
  = case_bop (f cEq cEq') (f cNotEq cNotEq') (f cLessThan cLessThan') (f cLessOrEqual cLessOrEqual') (f cGreaterThan cGreaterThan') (f cGreaterOrEqual cGreaterOrEqual') (f cAdd cAdd') (f cSubtract cSubtract') (f cMult cMult') (f cDiv cDiv') (f cMod cMod') (f cBinAnd cBinAnd') (f cBinOr cBinOr') (f cBinXor cBinXor') (f cShiftLeft cShiftLeft') (f cShiftRightZeros cShiftRightZeros') (f cShiftRightSigned cShiftRightSigned') bop"
by(simp split: bop.split)

lemma sup_case_bop_case_bop_other [code_unfold]:
  fixes p :: "'a :: semilattice_sup" shows
  "sup_class.sup (case_bop cEq cNotEq cLessThan cLessOrEqual cGreaterThan cGreaterOrEqual cAdd cSubtract cMult cDiv cMod cBinAnd cBinOr cBinXor cShiftLeft cShiftRightZeros cShiftRightSigned bop)
     (sup_class.sup (case_bop cEq' cNotEq' cLessThan' cLessOrEqual' cGreaterThan' cGreaterOrEqual' cAdd' cSubtract' cMult' cDiv' cMod' cBinAnd' cBinOr' cBinXor' cShiftLeft' cShiftRightZeros' cShiftRightSigned' bop) p)
  = sup_class.sup (case_bop (sup_class.sup cEq cEq') (sup_class.sup cNotEq cNotEq') (sup_class.sup cLessThan cLessThan') (sup_class.sup cLessOrEqual cLessOrEqual') (sup_class.sup cGreaterThan cGreaterThan') (sup_class.sup cGreaterOrEqual cGreaterOrEqual') (sup_class.sup cAdd cAdd') (sup_class.sup cSubtract cSubtract') (sup_class.sup cMult cMult') (sup_class.sup cDiv cDiv') (sup_class.sup cMod cMod') (sup_class.sup cBinAnd cBinAnd') (sup_class.sup cBinOr cBinOr') (sup_class.sup cBinXor cBinXor') (sup_class.sup cShiftLeft cShiftLeft') (sup_class.sup cShiftRightZeros cShiftRightZeros') (sup_class.sup cShiftRightSigned cShiftRightSigned') bop) p"
apply(cases bop)
apply(simp_all add: inf_sup_aci sup.assoc)
done

declare op_case_bop_case_bop_same[where f="sup_class.sup", code_unfold]

end

Theory JVMExec_Execute

(*  Title:      JinjaThreads/Execute/JVMExec_Execute.thy
    Author:     Andreas Lochbihler
*)

theory JVMExec_Execute
imports
  "../JVM/JVMExec"
  ExternalCall_Execute
begin

subsection ‹Manual translation of the JVM to use sets instead of predicates›

locale JVM_heap_execute = heap_execute +
  constrains addr2thread_id :: "('addr :: addr)  'thread_id" 
  and thread_id2addr :: "'thread_id  'addr" 
  and spurious_wakeups :: bool
  and empty_heap :: "'heap" 
  and allocate :: "'heap  htype  ('heap × 'addr) set" 
  and typeof_addr :: "'heap  'addr  htype option" 
  and heap_read :: "'heap  'addr  addr_loc  'addr val set" 
  and heap_write :: "'heap  'addr  addr_loc  'addr val  'heap set"

sublocale JVM_heap_execute < execute: JVM_heap_base
  addr2thread_id thread_id2addr 
  spurious_wakeups
  empty_heap allocate typeof_addr
  "λh a ad v. v  heap_read h a ad" "λh a ad v h'. h'  heap_write h a ad v"
.

context JVM_heap_execute begin

definition exec_instr ::
  "'addr instr  'addr jvm_prog  'thread_id  'heap  'addr val list  'addr val list
   cname  mname  pc  'addr frame list 
   (('addr, 'thread_id, 'heap) jvm_thread_action × ('addr, 'heap) jvm_state) set"
where [simp]: "exec_instr = execute.exec_instr"

lemma exec_instr_code [code]:
  "exec_instr (Load n) P t h stk loc C0 M0 pc frs = 
   {(ε, (None, h, ((loc ! n) # stk, loc, C0, M0, pc+1)#frs))}"
  "exec_instr (Store n) P t h stk loc C0 M0 pc frs = 
   {(ε, (None, h, (tl stk, loc[n:=hd stk], C0, M0, pc+1)#frs))}"
  "exec_instr (Push v) P t h stk loc C0 M0 pc frs = 
   {(ε, (None, h, (v # stk, loc, C0, M0, pc+1)#frs))}"
  "exec_instr (New C) P t h stk loc C0 M0 pc frs = 
   (let HA = allocate h (Class_type C) in
    if HA = {} then {(ε, execute.addr_of_sys_xcpt OutOfMemory, h, (stk, loc, C0, M0, pc) # frs)}
    else do { (h', a)  HA; {(NewHeapElem a (Class_type C), None, h', (Addr a # stk, loc, C0, M0, pc + 1)#frs)} })"
  "exec_instr (NewArray T) P t h stk loc C0 M0 pc frs =
   (let si = the_Intg (hd stk);
        i = nat (sint si)
    in if si <s 0
       then {(ε, execute.addr_of_sys_xcpt NegativeArraySize, h, (stk, loc, C0, M0, pc) # frs)}
       else let HA = allocate h (Array_type T i) in
         if HA = {} then {(ε, execute.addr_of_sys_xcpt OutOfMemory, h, (stk, loc, C0, M0, pc) # frs)}
         else do { (h', a)  HA; {(NewHeapElem a (Array_type T i), None, h', (Addr a # tl stk, loc, C0, M0, pc + 1) # frs)}})"
  "exec_instr ALoad P t h stk loc C0 M0 pc frs =
   (let va = hd (tl stk)
    in (if va = Null then {(ε, execute.addr_of_sys_xcpt NullPointer, h, (stk, loc, C0, M0, pc) # frs)}
        else 
          let i = the_Intg (hd stk);
              a = the_Addr va;
              len = alen_of_htype (the (typeof_addr h a))
          in if i <s 0  int len  sint i then
               {(ε, execute.addr_of_sys_xcpt ArrayIndexOutOfBounds, h, (stk, loc, C0, M0, pc) # frs)}
             else do {
                 v  heap_read h a (ACell (nat (sint i)));
                 {(ReadMem a (ACell (nat (sint i))) v, None, h, (v # tl (tl stk), loc, C0, M0, pc + 1) # frs)}
               }))"
  "exec_instr AStore P t h stk loc C0 M0 pc frs =
  (let ve = hd stk;
       vi = hd (tl stk);
       va = hd (tl (tl stk))
   in (if va = Null then {(ε, execute.addr_of_sys_xcpt NullPointer, h, (stk, loc, C0, M0, pc) # frs)}
       else (let i = the_Intg vi;
                 idx = nat (sint i);
                 a = the_Addr va;
                 hT = the (typeof_addr h a);
                 T = ty_of_htype hT;
                 len = alen_of_htype hT;
                 U = the (execute.typeof_h h ve)
             in (if i <s 0  int len  sint i then
                      {(ε, execute.addr_of_sys_xcpt ArrayIndexOutOfBounds, h, (stk, loc, C0, M0, pc) # frs)}
                 else if P  U  the_Array T then 
                      do {
                         h'  heap_write h a (ACell idx) ve;
                         {(WriteMem a (ACell idx) ve, None, h', (tl (tl (tl stk)), loc, C0, M0, pc+1) # frs)}
                      }
                 else {(ε, (execute.addr_of_sys_xcpt ArrayStore, h, (stk, loc, C0, M0, pc) # frs))}))))"
  "exec_instr ALength P t h stk loc C0 M0 pc frs =
   {(ε, (let va = hd stk
         in if va = Null
            then (execute.addr_of_sys_xcpt NullPointer, h, (stk, loc, C0, M0, pc) # frs)
            else (None, h, (Intg (word_of_int (int (alen_of_htype (the (typeof_addr h (the_Addr va)))))) # tl stk, loc, C0, M0, pc+1) # frs)))}"
  "exec_instr (Getfield F C) P t h stk loc C0 M0 pc frs = 
   (let v = hd stk
    in if v = Null then {(ε, execute.addr_of_sys_xcpt NullPointer, h, (stk, loc, C0, M0, pc) # frs)}
       else let a = the_Addr v
            in do {
               v'  heap_read h a (CField C F);
               {(ReadMem a (CField C F) v', None, h, (v' # (tl stk), loc, C0, M0, pc + 1) # frs)}
            })"
  "exec_instr (Putfield F C) P t h stk loc C0 M0 pc frs = 
  (let v = hd stk;
       r = hd (tl stk)
   in if r = Null then {(ε, execute.addr_of_sys_xcpt NullPointer, h, (stk, loc, C0, M0, pc) # frs)}
      else let a = the_Addr r
           in do {
                h'  heap_write h a (CField C F) v;
                {(WriteMem a (CField C F) v, None, h', (tl (tl stk), loc, C0, M0, pc + 1) # frs)}
              })"
 "exec_instr (Checkcast T) P t h stk loc C0 M0 pc frs =
  {(ε, let U = the (typeofh (hd stk))
       in if P  U  T then (None, h, (stk, loc, C0, M0, pc + 1) # frs)
          else (execute.addr_of_sys_xcpt ClassCast, h, (stk, loc, C0, M0, pc) # frs))}"
  "exec_instr (Instanceof T) P t h stk loc C0 M0 pc frs =
   {(ε, None, h, (Bool (hd stk  Null  P  the (typeofh (hd stk))  T) # tl stk, loc, C0, M0, pc + 1) # frs)}"
  "exec_instr (Invoke M n) P t h stk loc C0 M0 pc frs =
   (let r = stk ! n
    in (if r = Null then {(ε, execute.addr_of_sys_xcpt NullPointer, h, (stk, loc, C0, M0, pc) # frs)}
        else (let ps = rev (take n stk);
                  a = the_Addr r;
                  T = the (typeof_addr h a);
                  (D,M',Ts,meth)= method P (class_type_of T) M
         in case meth of 
               Native 
                      do {
                        (ta, va, h')  red_external_aggr P t a M ps h;
                        {(extTA2JVM P ta, extRet2JVM n h' stk loc C0 M0 pc frs va)}
                      }
            | (mxs,mxl0,ins,xt) 
              let f' = ([],[r]@ps@(replicate mxl0 undefined_value),D,M,0)
              in {(ε, None, h, f' # (stk, loc, C0, M0, pc) # frs)})))"
  "exec_instr Return P t h stk0 loc0 C0 M0 pc frs =
   {(ε, (if frs=[] then (None, h, []) 
         else 
           let v = hd stk0; 
               (stk,loc,C,m,pc) = hd frs;
                n = length (fst (snd (method P C0 M0)))
           in (None, h, (v#(drop (n+1) stk),loc,C,m,pc+1)#tl frs)))}"
  "exec_instr Pop P t h stk loc C0 M0 pc frs = {(ε, (None, h, (tl stk, loc, C0, M0, pc+1)#frs))}"
  "exec_instr Dup P t h stk loc C0 M0 pc frs = {(ε, (None, h, (hd stk # stk, loc, C0, M0, pc+1)#frs))}"
  "exec_instr Swap P t h stk loc C0 M0 pc frs = {(ε, (None, h, (hd (tl stk) # hd stk # tl (tl stk), loc, C0, M0, pc+1)#frs))}"
  "exec_instr (BinOpInstr bop) P t h stk loc C0 M0 pc frs =
   {(ε, 
     case the (execute.binop bop (hd (tl stk)) (hd stk)) of
       Inl v  (None, h, (v # tl (tl stk), loc, C0, M0, pc + 1) # frs)
     | Inr a  (Some a, h, (stk, loc, C0, M0, pc) # frs))}"
  "exec_instr (IfFalse i) P t h stk loc C0 M0 pc frs =
   {(ε, (let pc' = if hd stk = Bool False then nat(int pc+i) else pc+1
         in (None, h, (tl stk, loc, C0, M0, pc')#frs)))}"
  "exec_instr (Goto i) P t h stk loc C0 M0 pc frs = {(ε, (None, h, (stk, loc, C0, M0, nat(int pc+i))#frs))}"
  "exec_instr ThrowExc P t h stk loc C0 M0 pc frs =
   {(ε, (let xp' = if hd stk = Null then execute.addr_of_sys_xcpt NullPointer else the_Addr(hd stk)
         in (xp', h, (stk, loc, C0, M0, pc)#frs)))}"
  "exec_instr MEnter P t h stk loc C0 M0 pc frs =
   {(let v = hd stk
     in if v = Null
        then (ε, execute.addr_of_sys_xcpt NullPointer, h, (stk, loc, C0, M0, pc) # frs)
        else (Lockthe_Addr v, SyncLock (the_Addr v), None, h, (tl stk, loc, C0, M0, pc + 1) # frs))}"
  "exec_instr MExit P t h stk loc C0 M0 pc frs =
   (let v = hd stk
    in if v = Null
       then {(ε, execute.addr_of_sys_xcpt NullPointer, h, (stk, loc, C0, M0, pc) # frs)}
       else {(Unlockthe_Addr v, SyncUnlock (the_Addr v), None, h, (tl stk, loc, C0, M0, pc + 1) # frs),
             (UnlockFailthe_Addr v, execute.addr_of_sys_xcpt IllegalMonitorState, h, (stk, loc, C0, M0, pc) # frs)})"
by(auto 4 4 intro: rev_bexI)

definition exec :: "'addr jvm_prog  'thread_id  ('addr, 'heap) jvm_state  ('addr, 'thread_id, 'heap) jvm_ta_state set"
where "exec = execute.exec"

lemma exec_code:
  "exec P t (xcp, h, []) = {}"
  "exec P t (None, h, (stk, loc, C, M, pc) # frs) = exec_instr (instrs_of P C M ! pc) P t h stk loc C M pc frs"
  "exec P t (a, h, fr # frs) = {(ε, execute.exception_step P a h fr frs)}"
by(simp_all add: exec_def)

definition exec_1 ::
  "'addr jvm_prog  'thread_id  ('addr, 'heap) jvm_state
    (('addr, 'thread_id, 'heap) jvm_thread_action × ('addr, 'heap) jvm_state) Predicate.pred"
where "exec_1 P t σ = pred_of_set (exec P t σ)"

lemma exec_1I: "execute.exec_1 P t σ ta σ'  Predicate.eval (exec_1 P t σ) (ta, σ')"
by(erule execute.exec_1.cases)(simp add: exec_1_def exec_def)

lemma exec_1E:
  assumes "Predicate.eval (exec_1 P t σ) (ta, σ')"
  obtains "execute.exec_1 P t σ ta σ'"
using assms
by(auto simp add: exec_1_def exec_def intro: execute.exec_1.intros)

lemma exec_1_eq [simp]:
  "Predicate.eval (exec_1 P t σ) (ta, σ')  execute.exec_1 P t σ ta σ'"
by(auto intro: exec_1I elim: exec_1E)

lemma exec_1_eq':
  "Predicate.eval (exec_1 P t σ) = (λ(ta, σ'). execute.exec_1 P t σ ta σ')"
by(rule ext)(simp split: prod.split)

end

lemmas [code] = 
  JVM_heap_execute.exec_instr_code
  JVM_heap_base.exception_step.simps
  JVM_heap_execute.exec_code
  JVM_heap_execute.exec_1_def

end

Theory JVM_Execute

(*  Title:      JinjaThreads/Execute/JVM_Execute.thy
    Author:     Andreas Lochbihler
*)

theory JVM_Execute
imports
  SC_Schedulers
  JVMExec_Execute
  "../BV/BVProgressThreaded"
begin

abbreviation sc_heap_read_cset :: "heap  addr  addr_loc  addr val set"
where "sc_heap_read_cset h ad al  set_of_pred (sc_heap_read_i_i_i_o h ad al)"

abbreviation sc_heap_write_cset :: "heap  addr  addr_loc  addr val  heap set"
where "sc_heap_write_cset h ad al v  set_of_pred (sc_heap_write_i_i_i_i_o h ad al v)"

interpretation sc: 
  JVM_heap_execute
    "addr2thread_id"
    "thread_id2addr"
    "sc_spurious_wakeups"
    "sc_empty"
    "sc_allocate P"
    "sc_typeof_addr"
    "sc_heap_read_cset"
    "sc_heap_write_cset"
  rewrites "h ad al v. v  sc_heap_read_cset h ad al  sc_heap_read h ad al v"
  and "h ad al v h'. h'  sc_heap_write_cset h ad al v  sc_heap_write h ad al v h'"
  for P
apply(simp_all add: eval_sc_heap_read_i_i_i_o eval_sc_heap_write_i_i_i_i_o)
done

interpretation sc_execute: 
  JVM_conf_read
    "addr2thread_id"
    "thread_id2addr"
    "sc_spurious_wakeups"
    "sc_empty"
    "sc_allocate P"
    "sc_typeof_addr"
    "sc_heap_read"
    "sc_heap_write"
    "sc_hconf P"
  for P
by(unfold_locales)

fun sc_mexec :: 
  "addr jvm_prog  thread_id  (addr jvm_thread_state × heap) 
   ((addr, thread_id, heap) jvm_thread_action × addr jvm_thread_state × heap) Predicate.pred"
where 
  "sc_mexec P t ((xcp, frs), h) =
   sc.exec_1 (TYPE(addr jvm_method)) P P t (xcp, h, frs)  (λ(ta, xcp, h, frs). Predicate.single (ta, (xcp, frs), h))"

abbreviation sc_jvm_start_state_refine :: 
  "addr jvm_prog  cname  mname  addr val list  
  (addr, thread_id, heap, (thread_id, (addr jvm_thread_state) × addr released_locks) rm, (thread_id, addr wait_set_status) rm, thread_id rs) state_refine"
where
  "sc_jvm_start_state_refine  
   sc_start_state_refine (rm_empty ()) rm_update (rm_empty ()) (rs_empty ()) (λC M Ts T (mxs, mxl0, b) vs. (None, [([], Null # vs @ replicate mxl0 undefined_value, C, M, 0)]))"

abbreviation sc_jvm_state_invar :: "addr jvm_prog  tyP  (addr,thread_id,addr jvm_thread_state,heap,addr) state set"
where "sc_jvm_state_invar P Φ  {s. sc_execute.correct_state_ts P Φ (thr s) (shr s)}"

lemma eval_sc_mexec:
  "(λt xm ta x'm'. Predicate.eval (sc_mexec P t xm) (ta, x'm')) = 
  (λt ((xcp, frs), h) ta ((xcp', frs'), h'). sc.execute.exec_1 (TYPE(addr jvm_method)) P P t (xcp, h, frs) ta (xcp', h', frs'))"
by(rule ext)+(fastforce intro!: SUP1_I simp add: sc.exec_1_eq')

lemma sc_jvm_start_state_invar: 
  assumes "wf_jvm_progΦ P"
  and "sc_wf_start_state P C M vs"
  shows "sc_state_α (sc_jvm_start_state_refine P C M vs)  sc_jvm_state_invar P Φ"
using sc_execute.correct_jvm_state_initial[OF assms]
by(simp add: sc_execute.correct_jvm_state_def)

subsection ‹Round-robin scheduler›

interpretation JVM_rr: 
  sc_round_robin_base
    JVM_final "sc_mexec P" convert_RA Jinja_output
  for P
.

definition sc_rr_JVM_start_state :: "nat  'm prog  thread_id fifo round_robin"
where "sc_rr_JVM_start_state n0 P = JVM_rr.round_robin_start n0 (sc_start_tid P)"

definition exec_JVM_rr ::
  "nat  addr jvm_prog  cname  mname  addr val list  
  (thread_id × (addr, thread_id) obs_event list, 
   (addr, thread_id) locks × ((thread_id, addr jvm_thread_state × addr released_locks) rm × heap) ×
   (thread_id, addr wait_set_status) rm × thread_id rs) tllist"
where
  "exec_JVM_rr n0 P C M vs = JVM_rr.exec P n0 (sc_rr_JVM_start_state n0 P) (sc_jvm_start_state_refine P C M vs)"

interpretation JVM_rr:
  sc_round_robin 
    JVM_final "sc_mexec P" convert_RA Jinja_output
  for P
by(unfold_locales)

lemma JVM_rr:
  assumes "wf_jvm_progΦ P"
  shows
  "sc_scheduler 
     JVM_final (sc_mexec P) convert_RA
     (JVM_rr.round_robin P n0) (pick_wakeup_via_sel (λs P. rm_sel s (λ(k,v). P k v))) JVM_rr.round_robin_invar
     (sc_jvm_state_invar P Φ)"
unfolding sc_scheduler_def
apply(rule JVM_rr.round_robin_scheduler)
apply(unfold eval_sc_mexec)
apply(rule sc_execute.mexec_deterministic[OF assms sc_deterministic_heap_ops])
apply(simp add: sc_spurious_wakeups)
done

subsection ‹Random scheduler›

interpretation JVM_rnd: 
  sc_random_scheduler_base
    JVM_final "sc_mexec P" convert_RA Jinja_output
  for P
.

definition sc_rnd_JVM_start_state :: "Random.seed  random_scheduler"
where "sc_rnd_JVM_start_state seed = seed"

definition exec_JVM_rnd ::
  "Random.seed  addr jvm_prog  cname  mname  addr val list  
  (thread_id × (addr, thread_id) obs_event list,
   (addr, thread_id) locks × ((thread_id, addr jvm_thread_state × addr released_locks) rm × heap) ×
   (thread_id, addr wait_set_status) rm × thread_id rs) tllist"
where "exec_JVM_rnd seed P C M vs = JVM_rnd.exec P (sc_rnd_JVM_start_state seed) (sc_jvm_start_state_refine P C M vs)"

interpretation JVM_rnd:
  sc_random_scheduler
    JVM_final "sc_mexec P" convert_RA Jinja_output
  for P
by(unfold_locales)

lemma JVM_rnd:
  assumes "wf_jvm_progΦ P"
  shows 
  "sc_scheduler
    JVM_final (sc_mexec P) convert_RA
    (JVM_rnd.random_scheduler P) (pick_wakeup_via_sel (λs P. rm_sel s (λ(k,v). P k v))) (λ_ _. True)
    (sc_jvm_state_invar P Φ)"
unfolding sc_scheduler_def
apply(rule JVM_rnd.random_scheduler_scheduler)
apply(unfold eval_sc_mexec)
apply(rule sc_execute.mexec_deterministic[OF assms sc_deterministic_heap_ops])
apply(simp add: sc_spurious_wakeups)
done

ML_val @{code exec_JVM_rr}

ML_val @{code exec_JVM_rnd}

end

Theory ToString

(*  Title:      JinjaThreads/Execute/ToString.thy
    Author:     Andreas Lochbihler
*)

section ‹String representation of types›

theory ToString imports
  "../J/Expr"
  "../JVM/JVMInstructions"
  (*"../../Collections/impl/TrieMapImpl"
  "../../Collections/impl/RBTMapImpl"
  "../../Collections/common/Assoc_List"*)
  "../Basic/JT_ICF"
begin

class toString =
  fixes toString :: "'a  String.literal"

instantiation bool :: toString begin
definition [code]: "toString b = (case b of True  STR ''True'' | False  STR ''False'')"
instance proof qed
end

instantiation char :: toString begin
definition [code]: "toString (c :: char) = String.implode [c]"
instance proof qed
end

instantiation String.literal :: toString begin
definition [code]: "toString (s :: String.literal) = s"
instance proof qed
end

fun list_toString :: "String.literal  'a :: toString list  String.literal list"
where
  "list_toString sep [] = []"
| "list_toString sep [x] = [toString x]"
| "list_toString sep (x#xs) = toString x # sep # list_toString sep xs"

instantiation list :: (toString) toString begin
definition [code]:
  "toString (xs :: 'a list) = sum_list (STR ''['' # list_toString (STR '','') xs @ [STR '']''])"
instance proof qed
end

definition digit_toString :: "int  String.literal"
where
  "digit_toString k = (if k = 0 then STR ''0''
    else if k = 1 then STR ''1''
    else if k = 2 then STR ''2''
    else if k = 3 then STR ''3''
    else if k = 4 then STR ''4''
    else if k = 5 then STR ''5''
    else if k = 6 then STR ''6''
    else if k = 7 then STR ''7''
    else if k = 8 then STR ''8''
    else if k = 9 then STR ''9''
    else undefined)"

function int_toString :: "int  String.literal list"
where
  "int_toString n = 
  (if n < 0 then STR ''-'' # int_toString (- n)
   else if n < 10 then [digit_toString n ]
   else int_toString (n div 10) @ [digit_toString (n mod 10)])"
by pat_completeness simp
termination by size_change

instantiation int :: toString begin
definition [code]: "toString i = sum_list (int_toString i)"
instance proof qed
end

instantiation nat :: toString begin
definition [code]: "toString n = toString (int n)"
instance proof qed
end

instantiation option :: (toString) toString begin
primrec toString_option :: "'a option  String.literal" where
  "toString None = STR ''None''"
| "toString (Some a) = sum_list [STR ''Some ('', toString a, STR '')'']"
instance proof qed
end

instantiation finfun :: ("{toString, card_UNIV, equal, linorder}", toString) toString begin
definition [code]: 
  "toString (f :: 'a ⇒f 'b) = 
   sum_list 
     (STR ''('' 
     # toString (finfun_default f) 
     # concat (map (λx. [STR '','', toString x, STR ''|->'', toString (f $ x)]) (finfun_to_list f)) 
     @ [STR '')''])"
instance proof qed
end

instantiation word :: (len) toString begin
definition [code]: "toString (w :: 'a word) = toString (sint w)"
instance proof qed
end

instantiation "fun" :: (type, type) toString begin
definition [code]: "toString (f :: 'a  'b) = STR ''fn''"
instance proof qed
end

instantiation val :: (toString) toString begin
fun toString_val :: "('a :: toString) val  String.literal"
where
  "toString Unit = STR ''Unit''"
| "toString Null = STR ''Null''"
| "toString (Bool b) = sum_list [STR ''Bool '', toString b]"
| "toString (Intg i) = sum_list [STR ''Intg '', toString i]"
| "toString (Addr a) = sum_list [STR ''Addr '', toString a]"
instance proof qed
end

instantiation ty :: toString begin
primrec toString_ty :: "ty  String.literal"
where
  "toString Void = STR ''Void''"
| "toString Boolean = STR ''Boolean''"
| "toString Integer = STR ''Integer''"
| "toString NT = STR ''NT''"
| "toString (Class C) = sum_list [STR ''Class '', toString C]"
| "toString (T⌊⌉) = sum_list [toString T, STR ''[]'']"
instance proof qed
end

instantiation bop :: toString begin
primrec toString_bop :: "bop  String.literal" where
  "toString Eq = STR ''==''"
| "toString NotEq = STR ''!=''"
| "toString LessThan = STR ''<''"
| "toString LessOrEqual = STR ''<=''"
| "toString GreaterThan = STR ''>''"
| "toString GreaterOrEqual = STR ''>=''"
| "toString Add = STR ''+''"
| "toString Subtract = STR ''-''"
| "toString Mult = STR ''*''"
| "toString Div = STR ''/''"
| "toString Mod = STR ''%''"
| "toString BinAnd = STR ''&''"
| "toString BinOr = STR ''|''"
| "toString BinXor = STR ''^''"
| "toString ShiftLeft = STR ''<<''"
| "toString ShiftRightZeros = STR ''>>''"
| "toString ShiftRightSigned = STR ''>>>''"
instance proof qed
end

instantiation addr_loc :: toString begin
primrec toString_addr_loc :: "addr_loc  String.literal" where
  "toString (CField C F) = sum_list [STR ''CField '', F, STR ''{'', C, STR ''}'']"
| "toString (ACell n) = sum_list [STR ''ACell '', toString n]"
instance proof qed
end

instantiation htype :: toString begin
fun toString_htype :: "htype  String.literal" where
  "toString (Class_type C) = C"
| "toString (Array_type T n) = sum_list [toString T, STR ''['', toString n, STR '']'']"
instance proof qed
end

instantiation obs_event :: (toString, toString) toString begin
primrec toString_obs_event :: "('a :: toString, 'b :: toString) obs_event  String.literal"
where
  "toString (ExternalCall ad M vs v) = 
   sum_list [STR ''ExternalCall '', M, STR ''('', toString vs, STR '') = '', toString v]"
| "toString (ReadMem ad al v) =
   sum_list [STR ''ReadMem '', toString ad, STR ''@'', toString al, STR ''='', toString v]"
| "toString (WriteMem ad al v) =
   sum_list [STR ''WriteMem '', toString ad, STR ''@'', toString al, STR ''='', toString v]"
| "toString (NewHeapElem ad hT) = sum_list [STR ''Allocate '', toString ad, STR '':'', toString hT]"
| "toString (ThreadStart t) = sum_list [STR ''ThreadStart '', toString t]"
| "toString (ThreadJoin t) = sum_list [STR ''ThreadJoin '', toString t]"
| "toString (SyncLock ad) = sum_list [STR ''SyncLock '', toString ad]"
| "toString (SyncUnlock ad) = sum_list [STR ''SyncUnlock '', toString ad]"
| "toString (ObsInterrupt t) = sum_list [STR ''Interrupt '', toString t]"
| "toString (ObsInterrupted t) = sum_list [STR ''Interrupted '', toString t]"
instance proof qed
end

instantiation prod :: (toString, toString) toString begin
definition "toString = (λ(a, b). sum_list [STR ''('', toString a, STR '', '', toString b, STR '')''])"
instance proof qed
end

instantiation fmod_ext :: (toString) toString begin
definition "toString fd = sum_list [STR ''{|volatile='', toString (volatile fd), STR '', '', toString (fmod.more fd), STR ''|}'']"
instance proof qed
end

instantiation unit :: toString begin
definition "toString (u :: unit) = STR ''()''"
instance proof qed
end

instantiation exp :: (toString, toString, toString) toString begin
fun toString_exp :: "('a :: toString, 'b :: toString, 'c :: toString) exp  String.literal"
where
  "toString (new C) = sum_list [STR ''new '', C]"
| "toString (newArray T e) = sum_list [STR ''new '', toString T, STR ''['', toString e, STR '']'']"
| "toString (Cast T e) = sum_list [STR ''('', toString T, STR '') ('', toString e, STR '')'']"
| "toString (InstanceOf e T) = sum_list [STR ''('', toString e, STR '') instanceof '', toString T]"
| "toString (Val v) = sum_list [STR ''Val ('', toString v, STR '')'']"
| "toString (e1 «bop» e2) = sum_list [STR ''('', toString e1, STR '') '', toString bop, STR '' ('', toString e2, STR '')'']"
| "toString (Var V) = sum_list [STR ''Var '', toString V]"
| "toString (V := e) = sum_list [toString V, STR '' := ('', toString e, STR '')'']"
| "toString (AAcc a i) = sum_list [STR ''('', toString a, STR '')['', toString i, STR '']'']"
| "toString (AAss a i e) = sum_list [STR ''('', toString a, STR '')['', toString i, STR ''] := ('', toString e, STR '')'']"
| "toString (ALen a) = sum_list [STR ''('', toString a, STR '').length'']"
| "toString (FAcc e F D) = sum_list [STR ''('', toString e, STR '').'', F, STR ''{'', D, STR ''}'']"
| "toString (FAss e F D e') = sum_list [STR ''('', toString e, STR '').'', F, STR ''{'', D, STR ''} := ('', toString e', STR '')'']"
| "toString (Call e M es) = sum_list ([STR ''('', toString e, STR '').'', M, STR ''(''] @ map toString es @ [STR '')''])"
| "toString (Block V T vo e) = sum_list ([STR ''{'', toString V, STR '':'', toString T] @ (case vo of None  [] | Some v  [STR ''='', toString v]) @ [STR ''; '', toString e, STR ''}''])"
| "toString (Synchronized V e e') = sum_list [STR ''synchronized_'', toString V, STR ''_('', toString e, STR '') {'', toString e', STR ''}'']"
| "toString (InSynchronized V ad e) = sum_list [STR ''insynchronized_'', toString V, STR ''_('', toString ad, STR '') {'', toString e, STR ''}'']"
| "toString (e;;e') = sum_list [toString e, STR ''; '', toString e']"
| "toString (if (e) e' else e'') = sum_list [STR ''if ('', toString e, STR '') { '', toString e', STR '' } else { '', toString e'', STR ''}'']"
| "toString (while (e) e') = sum_list [STR ''while ('', toString e, STR '') { '', toString e', STR '' }'']"
| "toString (throw e) = sum_list [STR ''throw ('', toString e, STR '')'']"
| "toString (try e catch(C V) e') = sum_list [STR ''try { '', toString e, STR '' } catch ('', C, STR '' '', toString V, STR '') { '', toString e', STR '' }'']"
instance proof qed
end

instantiation instr :: (toString) toString begin
primrec toString_instr :: "'a instr  String.literal" where
  "toString (Load i) = sum_list [STR ''Load ('', toString i, STR '')'']"
| "toString (Store i) = sum_list [STR ''Store ('', toString i, STR '')'']"
| "toString (Push v) = sum_list [STR ''Push ('', toString v, STR '')'']"
| "toString (New C) = sum_list [STR ''New '', toString C]"
| "toString (NewArray T) = sum_list [STR ''NewArray '', toString T]"
| "toString ALoad = STR ''ALoad''"
| "toString AStore = STR ''AStore''"
| "toString ALength = STR ''ALength''"
| "toString (Getfield F D) = sum_list [STR ''Getfield  '', toString F, STR '' '', toString D]"
| "toString (Putfield F D) = sum_list [STR ''Putfield  '', toString F, STR '' '', toString D]"
| "toString (Checkcast T) = sum_list [STR ''Checkcast '', toString T]"
| "toString (Instanceof T) = sum_list [STR ''Instanceof '', toString T]"
| "toString (Invoke M n) =  sum_list [STR ''Invoke '', toString M, STR '' '', toString n]"
| "toString Return = STR ''Return''"
| "toString Pop = STR ''Pop''"
| "toString Dup = STR ''Dup''"
| "toString Swap = STR ''Swap''"
| "toString (BinOpInstr bop) = sum_list [STR ''BinOpInstr  '', toString bop]"
| "toString (Goto i) = sum_list [STR ''Goto '', toString i]"
| "toString (IfFalse i) = sum_list [STR ''IfFalse '', toString i]"
| "toString ThrowExc = STR ''ThrowExc''"
| "toString MEnter = STR ''monitorenter''"
| "toString MExit = STR ''monitorexit''"
instance proof qed
end

instantiation trie :: (toString, toString) toString begin
definition [code]: "toString (t :: ('a, 'b) trie) = toString (tm_to_list t)"
instance proof qed
end

instantiation rbt :: ("{toString,linorder}", toString) toString begin
definition [code]: 
  "toString (t :: ('a, 'b) rbt) = 
   sum_list (list_toString (STR '',⏎'') (rm_to_list t))"
instance proof qed
end

instantiation assoc_list :: (toString, toString) toString begin
definition [code]: "toString = toString  Assoc_List.impl_of"
instance proof qed
end

code_printing
  class_instance String.literal :: toString  (Haskell) -

end

Theory Java2Jinja

(*  Title:      JinjaThreads/Execute/Java2Jinja.thy
    Author:     Andreas Lochbihler
*)

section ‹Setup for converter Java2Jinja›

theory Java2Jinja 
imports
  Code_Generation
  ToString
begin

code_identifier
  code_module Java2Jinja  (SML) Code_Generation

definition j_Program :: "addr J_mb cdecl list  addr J_prog"
where "j_Program = Program"

export_code wf_J_prog' j_Program in SML file ‹JWellForm.ML› 

text ‹Functions for extracting calls to the native print method›

definition purge where
  "run.
  purge run = 
  lmap (λobs. case obs of ExternalCall _ _ (Cons (Intg i) _) v  i)
  (lfilter
    (λobs. case obs of ExternalCall _ M (Cons (Intg i) Nil) _  M = print | _  False) 
    (lconcat (lmap (llist_of  snd) (llist_of_tllist run))))"

text ‹Various other functions›

instantiation heapobj :: toString begin
primrec toString_heapobj :: "heapobj  String.literal" where
  "toString (Obj C fs) = sum_list [STR ''(Obj '', toString C, STR '', '', toString fs, STR '')'']"
| "toString (Arr T si fs el) = 
   sum_list [STR ''(['', toString si, STR '']'', toString T, STR '', '', toString fs, STR '', '', toString (map snd (rm_to_list el)), STR '')'']"
instance proof qed
end

definition case_llist' where "case_llist' = case_llist"
definition case_tllist' where "case_tllist' = case_tllist"
definition terminal' where "terminal' = terminal"
definition llist_of_tllist' where "llist_of_tllist' = llist_of_tllist"
definition thr' where "thr' = thr"
definition shr' where "shr' = shr"

definition heap_toString :: "heap  String.literal"
where "heap_toString = toString"

definition thread_toString :: "(thread_id, (addr expr × addr locals) × (addr ⇒f nat)) rbt  String.literal"
where "thread_toString = toString"

definition thread_toString' :: "(thread_id, addr jvm_thread_state' × (addr ⇒f nat)) rbt  String.literal"
where "thread_toString' = toString"

definition trace_toString :: "thread_id × (addr, thread_id) obs_event list  String.literal"
where "trace_toString = toString"

code_identifier
  code_module Cardinality  (SML) Set
| code_module Conditionally_Complete_Lattices  (SML) Set
| code_module List  (SML) Set
| code_module Predicate  (SML) Set
| code_module Parity  (SML) Bit_Operations
| type_class semiring_parity  (SML) Bit_Operations.semiring_parity
| class_instance int :: semiring_parity  (SML) Bit_Operations.semiring_parity_int
| class_instance int :: ring_parity  (SML) Bit_Operations.semiring_parity_int
| constant member_i_i  (SML) Set.member_i_i

export_code
  wf_J_prog' exec_J_rr exec_J_rnd 
  j_Program
  purge case_llist' case_tllist' terminal' llist_of_tllist'
  thr' shr' heap_toString thread_toString trace_toString
  in SML
  file ‹J_Execute.ML›

definition j2jvm :: "addr J_prog  addr jvm_prog" where "j2jvm = J2JVM"

export_code
  wf_jvm_prog' exec_JVM_rr exec_JVM_rnd j2jvm
  j_Program 
  purge case_llist' case_tllist' terminal' llist_of_tllist'
  thr' shr' heap_toString thread_toString' trace_toString
  in SML
  file ‹JVM_Execute2.ML›

end

Theory Execute_Main

theory Execute_Main
imports
  SC_Schedulers
  PCompilerRefine
  Code_Generation
  JVM_Execute
  Java2Jinja
begin

end

Theory ApprenticeChallenge

(*  Title:      JinjaThreads/Examples/AppenticeChallenge.thy
    Author:     Andreas Lochbihler
*)

chapter ‹Examples›

section ‹Apprentice challenge›

theory ApprenticeChallenge 
imports
  "../Execute/Code_Generation"
begin

text ‹This theory implements the apprentice challenge by Porter and Moore \cite{MoorePorter2002TOPLAS}.›

definition ThreadC :: "addr J_mb cdecl"
where 
  "ThreadC = 
  (Thread, Object, [], 
    [(run, [], Void, ([], unit)),
     (start, [], Void, Native),
     (join, [], Void, Native),
     (interrupt, [], Void, Native),
     (isInterrupted, [], Boolean, Native)])"

definition Container :: cname
where "Container = STR ''Container''"

definition ContainerC :: "addr J_mb cdecl"
where "ContainerC = (Container, Object, [(STR ''counter'', Integer, volatile=False)], [])"

definition String :: cname
where "String = STR ''String''"

definition StringC :: "addr J_mb cdecl"
where
  "StringC = (String, Object, [], [])"

definition Job :: cname
where "Job = STR ''Job''"

definition JobC :: "addr J_mb cdecl"
where
  "JobC =
  (Job, Thread, [(STR ''objref'', Class Container, volatile=False)],
   [(STR ''incr'', [], Class Job, ([],
     sync(Var (STR ''objref''))
         ((Var (STR ''objref''))STR ''counter''{STR ''''} := ((Var (STR ''objref''))STR ''counter''{STR ''''} «Add» Val (Intg 1)));;
     Var this)),
    (STR ''setref'', [Class Container], Void, ([STR ''o''],
     LAss (STR ''objref'') (Var (STR ''o'')))),
    (run, [], Void, ([],
     while (true) (Var thisSTR ''incr''([]))))
    ])"

definition Apprentice :: cname
where "Apprentice = STR ''Apprentice''"

definition ApprenticeC :: "addr J_mb cdecl"
where
  "ApprenticeC =
  (Apprentice, Object, [],
   [(STR ''main'', [Class String⌊⌉], Void, ([STR ''args''],
    {STR ''container'':Class Container=None;
       (STR ''container'' := new Container);;
       (while (true) 
          {STR ''job'':Class Job=None;
              (STR ''job'' := new Job);;
              (Var (STR ''job'')STR ''setref''([Var (STR ''container'')]));;
              (Var (STR ''job'')Type.start([]))
          }
       )
    }))])"

definition ApprenticeChallenge
where
  "ApprenticeChallenge = Program (SystemClasses @ [StringC, ThreadC, ContainerC, JobC, ApprenticeC])"

definition ApprenticeChallenge_annotated
where "ApprenticeChallenge_annotated = annotate_prog_code ApprenticeChallenge"

lemma "wf_J_prog ApprenticeChallenge_annotated"
by eval

lemmas [code_unfold] = 
  Container_def Job_def String_def Apprentice_def

definition main :: "String.literal" where "main = STR ''main''"

ML_val val _ = tracing "started";
  val program = @{code ApprenticeChallenge_annotated};
  val _ = tracing "prg";
  val compiled = @{code J2JVM} program;
  val _ = tracing "compiled";

  @{code exec_J_rr}
    @{code "1 :: nat"}
    program
    @{code Apprentice}
    @{code main}
    [ @{code Null}];

  val _ = tracing "J_rr";
  @{code exec_JVM_rr} 
    @{code "1 :: nat"}
    compiled
    @{code Apprentice}
    @{code main}
    [ @{code Null}];
  val _ = tracing "JVM_rr";

end

Theory BufferExample

(*  Title:      JinjaThreads/Examples/BufferExample.thy
    Author:     Andreas Lochbihler
*)

section ‹Buffer example›

theory BufferExample imports 
  "../Execute/Code_Generation"
begin

definition ThreadC :: "addr J_mb cdecl"
where 
  "ThreadC = 
  (Thread, Object, [], 
    [(run, [], Void, ([], unit)),
     (start, [], Void, Native),
     (join, [], Void, Native),
     (interrupt, [], Void, Native),
     (isInterrupted, [], Boolean, Native)])"

definition IntegerC :: "addr J_mb cdecl"
where "IntegerC = (STR ''Integer'', Object, [(STR ''value'', Integer, volatile=False)], [])"

definition Buffer :: cname
where "Buffer = STR ''Buffer''"

definition BufferC :: "addr J_mb cdecl"
where
  "BufferC =
   (Buffer, Object,
    [(STR ''buffer'', Class Object⌊⌉, volatile=False),
     (STR ''front'', Integer, volatile=False),
     (STR ''back'', Integer, volatile=False),
     (STR ''size'', Integer, volatile=False)],
    [(STR ''constructor'', [Integer], Void, ([STR ''size''],
      (STR ''buffer'' := newA (Class Object)Var (STR ''size''));;
      (STR ''front'' := Val (Intg 0));;
      (STR ''back'' := Val (Intg (- 1)));;
      (Var this(STR ''size''){STR ''''} := Val (Intg 0)))),
     (STR ''empty'', [], Boolean, ([], sync(Var this) (Var (STR ''size'') «Eq» Val (Intg 0)))),
     (STR ''full'', [], Boolean, ([],
      sync(Var this) (Var (STR ''size'') «Eq» ((Var (STR ''buffer''))∙length)))),
     (STR ''get'', [], Class Object, ([],
      sync(Var this) (
        (while (Var this(STR ''empty'')([])) 
          (try (Var thiswait([])) catch(InterruptedException (STR ''e'')) unit));;
        (STR ''size'' := (Var (STR ''size'') «Subtract» Val (Intg 1)));;
        {(STR ''result''):Class Object=None; 
          ((STR ''result'') := ((Var (STR ''buffer''))Var (STR ''front'')));;
          (STR ''front'' := (Var (STR ''front'') «Add» Val (Intg 1)));;
          (if ((Var (STR ''front'')) «Eq» ((Var (STR ''buffer''))∙length))
             (STR ''front'' := Val (Intg 0))
           else unit);;
          (Var thisnotifyAll([]));;
          Var (STR ''result'')
        }
      ))),
     (STR ''put'', [Class Object], Void, ([STR ''o''],
      sync(Var this) (
        (while (Var thisSTR ''full''([]))
          (try (Var thiswait([])) catch(InterruptedException STR ''e'') unit));;
        (STR ''back'' := (Var (STR ''back'') «Add» Val (Intg 1)));;
        (if (Var (STR ''back'') «Eq» ((Var (STR ''buffer''))∙length))
           (STR ''back'' := Val (Intg 0))
         else unit);;
        (AAss (Var (STR ''buffer'')) (Var (STR ''back'')) (Var (STR ''o'')));;
        (STR ''size'' := ((Var (STR ''size'')) «Add» Val (Intg 1)));;
        (Var thisnotifyAll([]))
      )))
    ])"

definition Producer :: cname
where "Producer = STR ''Producer''"

definition ProducerC :: "int  addr J_mb cdecl"
where
  "ProducerC n =
   (Producer, Thread, [(STR ''buffer'', Class Buffer, volatile=False)],
    [(run, [], Void, ([],
     {STR ''i'':Integer=Intg 0;
        while (Var (STR ''i'') «NotEq» Val (Intg (word_of_int n))) (
          (Var (STR ''buffer''))STR ''put''([{STR ''temp'':Class (STR ''Integer'')=None; (STR ''temp'' := new (STR ''Integer'');; ((FAss (Var (STR ''temp'')) (STR ''value'') (STR '''') (Var (STR ''i'')));; Var (STR ''temp'')))} ]);;
          STR ''i'' := (Var (STR ''i'') «Add» (Val (Intg 1))))
     }))])"

definition Consumer :: cname
where "Consumer = STR ''Consumer''"

definition ConsumerC :: "int  addr J_mb cdecl"
where
  "ConsumerC n =
  (Consumer, Thread, [(STR ''buffer'', Class Buffer, volatile=False)],
   [(run, [], Void, ([],
    {STR ''i'':Integer=Intg 0;
      while (Var (STR ''i'') «NotEq» Val (Intg (word_of_int n))) (
        {STR ''o'':Class Object=None; 
          Seq (STR ''o'' := ((Var (STR ''buffer''))STR ''get''([])))
              (STR ''i'' := (Var (STR ''i'') «Add» Val (Intg 1)))})
    }))])"

definition String :: cname
where "String = STR ''String''"

definition StringC :: "addr J_mb cdecl"
where
  "StringC = (String, Object, [], [])"

definition Test :: cname
where "Test = STR ''Test''"

definition TestC :: "addr J_mb cdecl"
where
  "TestC =
  (Test, Object, [],
   [(STR ''main'', [Class String⌊⌉], Void, ([STR ''args''], 
    {STR ''b'':Class Buffer=None; (STR ''b'' := new Buffer);;
      (Var (STR ''b'')STR ''constructor''([Val (Intg 10)]));;
      {STR ''p'':Class Producer=None; STR ''p'' := new Producer;;
        {STR ''c'':Class Consumer=None; 
           (STR ''c'' := new Consumer);;
           (Var (STR ''c'')STR ''buffer''{STR ''''} := Var (STR ''b''));;
           (Var (STR ''p'')STR ''buffer''{STR ''''} := Var (STR ''b''));;
           (Var (STR ''c'')Type.start([]));;(Var (STR ''p'')Type.start([]))
        }
      }
    }))])"
    
definition BufferExample
where
  "BufferExample n = Program (SystemClasses @ [ThreadC, StringC, IntegerC, BufferC, ProducerC n, ConsumerC n, TestC])"

definition BufferExample_annotated
where
  "BufferExample_annotated n = annotate_prog_code (BufferExample n)"

lemmas [code_unfold] =
  IntegerC_def Buffer_def Producer_def Consumer_def Test_def
  String_def

lemma "wf_J_prog (BufferExample_annotated 10)"
by eval

definition main where "main = STR ''main''"
definition five :: int where "five = 5"

ML_val val program = @{code BufferExample_annotated} @{code "five"};
  val compiled = @{code J2JVM} program;

  val run = 
    @{code exec_J_rr}
      @{code "1 :: nat"}
      program
      @{code Test}
      @{code main}
      [ @{code Null}];
  val _ = @{code terminal} run;

  val jvm_run = 
    @{code exec_JVM_rr} 
      @{code "1 :: nat"}
      compiled
      @{code Test}
      @{code main}
      [ @{code Null}];
  val _ = @{code terminal} run;

end

Theory Examples_Main

theory Examples_Main
imports
  ApprenticeChallenge
  BufferExample
begin
end